From 8fcabd505e39b718336e57d104a84407bf6bf274 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 2 Sep 2022 00:18:18 +0200 Subject: reasonable delay forecasts --- lib/Server/ControlRoom.hs | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) (limited to 'lib/Server') diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 721d7df..9b61828 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,18 +17,20 @@ module Server.ControlRoom (ControlRoom(..)) where -import Control.Monad (forM_) +import Control.Monad (forM_, join) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.ByteString.Char8 as C8 import Data.Functor ((<&>)) import Data.List (lookup) +import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime(..), getCurrentTime, utctDay) +import Data.Time (UTCTime (..), getCurrentTime, + utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -39,6 +41,7 @@ import Database.Persist (Entity (..), delete, entityVal, get, import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) import Fmt ((+|), (|+)) +import GHC.Float (int2Double) import GHC.Generics (Generic) import Server.Util (Service) import Text.Blaze.Html (ToMarkup (..)) @@ -48,12 +51,12 @@ import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form -import Data.List.NonEmpty (nonEmpty) +import Extrapolation (Extrapolator (..), + LinearExtrapolator, secondsNow) import GTFS +import Numeric (showFFloat) import Persist -import Extrapolation (Extrapolator(..), LinearExtrapolator) -import Control.Monad (join) data ControlRoom = ControlRoom @@ -170,10 +173,11 @@ getTrainViewR trip day = do Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] - tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] + tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] <&> nonEmpty . (fmap entityVal) + nowSeconds <- secondsNow day defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) @@ -187,14 +191,19 @@ getTrainViewR trip day = do (_{Msgraw}) $nothing (_{MsgNoTrainPing}) -

Estimated Delay: Todo! +

_{MsgEstimatedDelay}: + $maybe history <- anchors + $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds + \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) + $nothing + (_{MsgNone})

_{MsgStops}
    $forall Stop{..} <- tripStops -
  1. #{stopArrival} #{stationName stopStation} +
  2. #{stopArrival} #{stationName stopStation} $maybe history <- anchors - $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day) + $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay})

    _{MsgAnnouncements} @@ -223,7 +232,8 @@ getTrainViewR trip day = do $else _{MsgBlockToken} |] - where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history + where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition @LinearExtrapolator history + guessAtSeconds = extrapolateAtSeconds @LinearExtrapolator getTripsViewR :: Handler Html -- cgit v1.2.3