diff options
| -rw-r--r-- | lib/Extrapolation.hs | 91 | ||||
| -rw-r--r-- | lib/GTFS.hs | 36 | ||||
| -rw-r--r-- | lib/Persist.hs | 5 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 30 | ||||
| -rw-r--r-- | messages/de.msg | 2 | ||||
| -rw-r--r-- | messages/en.msg | 2 |
6 files changed, 100 insertions, 66 deletions
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 6313a8e..770d4ce 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -1,25 +1,32 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -module Extrapolation (Extrapolator(..), LinearExtrapolator, linearDelay) where -import Data.Foldable (maximumBy, minimumBy) -import Data.Function (on) -import qualified Data.Map as M -import Data.Time (Day, UTCTime (UTCTime, utctDay), diffUTCTime, - nominalDiffTimeToSeconds) -import qualified Data.Vector as V -import GHC.Float (int2Double) -import GHC.IO (unsafePerformIO) -import Data.List.NonEmpty (NonEmpty) +module Extrapolation (Extrapolator(..), LinearExtrapolator, linearDelay, secondsNow) where +import Data.Foldable (maximumBy, minimumBy) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Time (Day, UTCTime (UTCTime, utctDay), + diffUTCTime, getCurrentTime, + nominalDiffTimeToSeconds) +import qualified Data.Vector as V +import GHC.Float (int2Double) +import GHC.IO (unsafePerformIO) -import Persist (Running (..), TrainAnchor (..), TrainPing (..)) -import GTFS (Depth (Deep), GTFS (..), Shape (..), Stop (..), - Time, Trip (..), stationGeopos, toSeconds, Seconds(..), seconds2Double) +import Conduit (MonadIO (liftIO)) +import Data.List (sortBy) +import GTFS (Depth (Deep), GTFS (..), Seconds (..), + Shape (..), Stop (..), Time, Trip (..), + seconds2Double, stationGeopos, toSeconds) +import Persist (Running (..), TrainAnchor (..), + TrainPing (..)) class Extrapolator a where -- | here's a position ping, guess things from that! @@ -40,30 +47,35 @@ instance Extrapolator LinearExtrapolator where $ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history where difference status = secondsNow - (trainAnchorWhen status) - extrapolateAtPosition = error "todo!" + -- note that this sorts (descending) for time first as a tie-breaker + -- (in case the train just stands still for a while, take the most recent update) + extrapolateAtPosition history positionNow = + fmap (minimumBy (compare `on` difference)) + $ NE.nonEmpty $ sortBy (flippedCompare `on` trainAnchorWhen) + $ NE.filter (\a -> trainAnchorSequence a < positionNow) history + where difference status = positionNow - (trainAnchorSequence status) + flippedCompare a b = case compare a b of + LT -> GT + GT -> LT + a -> a extrapolateAnchorFromPing gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor { trainAnchorCreated = trainPingTimestamp , trainAnchorTrip = runningTrip , trainAnchorDay = runningDay , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay - -- either do this ^ as a "time when the train *should* be here" or - -- replace it with a trainAnchorWhere; this isn't very useful to get - -- delays at stations - , trainAnchorDelay = Just (linearDelay gtfs trip ping runningDay) + , trainAnchorSequence + , trainAnchorDelay , trainAnchorMsg = Nothing } where Just trip = M.lookup runningTrip trips + (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping runningDay -linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> Seconds +linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double) linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ do - -- print (nextStop, lastStop) - -- print expectedTravelTime - -- -- print (((utcToSeconds trainPingTimestamp runningDay), toSeconds (stopDeparture lastStop))) - -- print (observedProgress, expectedProgress) - - -- these convoluted conversions necessary to get rounding in the right place - pure $ Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime) + print (scheduledPosition, round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime)) + pure $ (Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime) + , scheduledPosition) where closestPoint = minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line nextStop = snd $ @@ -78,17 +90,19 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ expectedTravelTime = toSeconds (stopArrival nextStop) tzseries runningDay - toSeconds (stopDeparture lastStop) tzseries runningDay - expectedProgress = + expectedProgress = crop $ seconds2Double (utcToSeconds trainPingTimestamp runningDay - toSeconds (stopDeparture lastStop) tzseries runningDay) / seconds2Double expectedTravelTime - -- where crop a - -- | a < 0 = 0 - -- | a > 1 = 1 - -- | otherwise = a + where crop a + | a < 0 = 0 + | a > 1 = 1 + | otherwise = a observedProgress = distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop) + scheduledPosition = + (int2Double $ stopSequence lastStop) + observedProgress * (int2Double $ stopSequence nextStop - stopSequence lastStop) distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double distanceAlongLine line p1 p2 = along2 - along1 @@ -106,6 +120,11 @@ utcToSeconds :: UTCTime -> Day -> Seconds utcToSeconds time day = Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0) +secondsNow :: MonadIO m => Day -> m Seconds +secondsNow runningDay = do + now <- liftIO getCurrentTime + pure $ utcToSeconds now runningDay + euclid :: Fractional f => (f,f) -> (f,f) -> f euclid (x1,y1) (x2,y2) = x*x + y*y where x = x1 - x2 diff --git a/lib/GTFS.hs b/lib/GTFS.hs index f5c2018..4e2a7dc 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | All kinds of stuff that has to deal with GTFS directly -- (i.e. parsing, querying, Aeson instances, etc.) @@ -37,8 +37,8 @@ import Data.Kind (Type) import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import Data.Time (TimeZone (timeZoneMinutes), - UTCTime (..), - dayOfWeek, getCurrentTime) + UTCTime (..), dayOfWeek, + getCurrentTime) import Data.Time.Calendar (Day, DayOfWeek (..)) import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid) import qualified Data.Time.Calendar.OrdinalDate as Day @@ -71,7 +71,7 @@ import qualified Data.Text as T import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries, timeZoneFromSeries) -import GHC.Float (int2Double) +import GHC.Float (int2Double) -- | for some reason this doesn't exist already in cassava diff --git a/lib/Persist.hs b/lib/Persist.hs index 371ddd0..aa040cf 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -45,9 +45,9 @@ import Data.Time (NominalDiffTime, TimeOfDay, import Data.Time.Calendar (Day, DayOfWeek (..)) import Data.Vector (Vector) import Database.Persist.Postgresql (SqlBackend) +import Fmt import GHC.Generics (Generic) import Web.PathPieces (PathPiece) -import Fmt newtype Token = Token UUID @@ -96,7 +96,8 @@ TrainAnchor json sql=tt_trip_anchor day Day created UTCTime when Seconds - delay Seconds Maybe + sequence Double + delay Seconds msg Text Maybe deriving Show Generic Eq ToSchema 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 (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>) $nothing <em>(_{MsgNoTrainPing}) - <p><strong>Estimated Delay</strong>: Todo! + <p><strong>_{MsgEstimatedDelay}</strong>: + $maybe history <- anchors + $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds + \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) + $nothing + <em> (_{MsgNone}) <section> <h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops - <li> #{stopArrival} #{stationName stopStation} + <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} $maybe history <- anchors - $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day) + $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) <section> <h2>_{MsgAnnouncements} @@ -223,7 +232,8 @@ getTrainViewR trip day = do $else <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> |] - where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history + where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition @LinearExtrapolator history + guessAtSeconds = extrapolateAtSeconds @LinearExtrapolator getTripsViewR :: Handler Html diff --git a/messages/de.msg b/messages/de.msg index 26f67ee..213337d 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -17,3 +17,5 @@ LastPing: Letzte Meldung TrainPing lat long time: #{lat},#{long}, um #{time} NoTrainPing: keine empfangen raw: roh +EstimatedDelay: Geschätzte Verspätung +OnStationSequence idx: an Stationsindex #{idx} diff --git a/messages/en.msg b/messages/en.msg index cc953ac..47bb66d 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -22,3 +22,5 @@ LastPing: Last Ping TrainPing lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time} NoTrainPing: none received raw: raw +EstimatedDelay: Estimated Delay +OnStationSequence idx@String: on station index #{idx} |