aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2022-09-02 00:18:18 +0200
committerstuebinm2022-09-02 00:18:18 +0200
commit8fcabd505e39b718336e57d104a84407bf6bf274 (patch)
tree78ad2baa11e51aad3fd804b6ac0544cb4ad35217
parentbaa7430e3bb19d25f2264571c990f850e67bd969 (diff)
reasonable delay forecasts
-rw-r--r--lib/Extrapolation.hs91
-rw-r--r--lib/GTFS.hs36
-rw-r--r--lib/Persist.hs5
-rw-r--r--lib/Server/ControlRoom.hs30
-rw-r--r--messages/de.msg2
-rw-r--r--messages/en.msg2
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}