diff options
| -rw-r--r-- | lib/Extrapolation.hs | 69 | ||||
| -rw-r--r-- | lib/GTFS.hs | 34 | ||||
| -rw-r--r-- | lib/Persist.hs | 15 | ||||
| -rw-r--r-- | lib/Server.hs | 4 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 16 |
5 files changed, 95 insertions, 43 deletions
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 4b427d0..6313a8e 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -3,52 +3,67 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} 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), diffUTCTime, +import Data.Time (Day, UTCTime (UTCTime, utctDay), diffUTCTime, nominalDiffTimeToSeconds) import qualified Data.Vector as V -import Persist (Running (..), TrainAnchor (..), TrainPing (..)) - import GHC.Float (int2Double) import GHC.IO (unsafePerformIO) -import GTFS (Depth (Deep), GTFS (..), Shape (..), Stop (..), - Time, Trip (..), stationGeopos, toSeconds) - +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Persist (Running (..), TrainAnchor (..), TrainPing (..)) +import GTFS (Depth (Deep), GTFS (..), Shape (..), Stop (..), + Time, Trip (..), stationGeopos, toSeconds, Seconds(..), seconds2Double) class Extrapolator a where - guessStatusAt :: [TrainAnchor] -> UTCTime -> TrainAnchor - guessAnchor :: GTFS -> Running -> TrainPing -> TrainAnchor + -- | here's a position ping, guess things from that! + extrapolateAnchorFromPing :: GTFS -> Running -> TrainPing -> TrainAnchor + + -- | extrapolate status at some time (i.e. "how much delay does the train have *now*?") + extrapolateAtSeconds :: NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor + -- | extrapolate status at some places (i.e. "how much delay will it have at the next station?") + extrapolateAtPosition :: NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor data LinearExtrapolator instance Extrapolator LinearExtrapolator where - guessStatusAt history when = - minimumBy (compare `on` difference) - $ filter (\a -> trainAnchorWhen a > when) history - where difference status = diffUTCTime when (trainAnchorWhen status) + -- TODO: this kind of sorting is bullshit; should look up depending on position, + -- not time (else there's glitches) + extrapolateAtSeconds history secondsNow = + fmap (minimumBy (compare `on` difference)) + $ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history + where difference status = secondsNow - (trainAnchorWhen status) - guessAnchor gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor + extrapolateAtPosition = error "todo!" + + extrapolateAnchorFromPing gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor { trainAnchorCreated = trainPingTimestamp , trainAnchorTrip = runningTrip , trainAnchorDay = runningDay - , trainAnchorWhen = trainPingTimestamp + , 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) , trainAnchorMsg = Nothing } where Just trip = M.lookup runningTrip trips -linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> Int +linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> Seconds linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ do - print (nextStop, lastStop) - print expectedTravelTime - -- print (((utcToSeconds trainPingTimestamp runningDay), toSeconds (stopDeparture lastStop))) - print (observedProgress, expectedProgress) - pure $ round $ (expectedProgress - observedProgress) * int2Double expectedTravelTime + -- 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) where closestPoint = minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line nextStop = snd $ @@ -61,12 +76,12 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ $ fmap (\stop -> (distanceAlongLine line closestPoint (stationGeopos $ stopStation stop), stop)) tripStops line = shapePoints tripShape expectedTravelTime = - toSeconds (stopArrival nextStop) tzseries trainPingTimestamp - - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp + toSeconds (stopArrival nextStop) tzseries runningDay + - toSeconds (stopDeparture lastStop) tzseries runningDay expectedProgress = - int2Double (utcToSeconds trainPingTimestamp runningDay - - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp) - / int2Double expectedTravelTime + seconds2Double (utcToSeconds trainPingTimestamp runningDay + - toSeconds (stopDeparture lastStop) tzseries runningDay) + / seconds2Double expectedTravelTime -- where crop a -- | a < 0 = 0 -- | a > 1 = 1 @@ -87,9 +102,9 @@ distanceAlongLine line p1 p2 = along2 - along1 -- | convert utc time to seconds on a day, with wrap-around -- for trains that cross midnight. -utcToSeconds :: UTCTime -> Day -> Int +utcToSeconds :: UTCTime -> Day -> Seconds utcToSeconds time day = - round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0) + Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0) euclid :: Fractional f => (f,f) -> (f,f) -> f euclid (x1,y1) (x2,y2) = x*x + y*y diff --git a/lib/GTFS.hs b/lib/GTFS.hs index 9eed8b5..f5c2018 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | All kinds of stuff that has to deal with GTFS directly -- (i.e. parsing, querying, Aeson instances, etc.) @@ -36,7 +37,7 @@ import Data.Kind (Type) import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import Data.Time (TimeZone (timeZoneMinutes), - UTCTime (utctDay), + UTCTime (..), dayOfWeek, getCurrentTime) import Data.Time.Calendar (Day, DayOfWeek (..)) import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid) @@ -70,6 +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) -- | for some reason this doesn't exist already in cassava @@ -100,13 +102,31 @@ instance ToJSON Time where toJSON (Time seconds _ tzname) = A.object [ "seconds" A..= seconds, "timezone" A..= tzname ] --- | converts a value of Time to seconds since midnight in UTC. Itself needs --- a UTCTime to resolve timezone changes, and the timezone info contained in --- the GTFS agency -toSeconds :: Time -> TimeZoneSeries -> UTCTime -> Int -toSeconds (Time seconds _ _) tzseries reftime = - seconds - timeZoneMinutes timezone * 60 +-- | a type for all timetable values lacking context +-- confusingly, usually displayed as minutes +newtype Seconds = Seconds { unSeconds :: Int } + deriving newtype + ( Num, ToJSON, FromJSON, Eq, Ord, FromHttpApiData + , Read, ToSchema ) + +instance Show Seconds where + show (Seconds s) = + if s > 0 then "+"+|s `div` 60|+"" + else show (s `div` 60) + +seconds2Double :: Seconds -> Double +seconds2Double = int2Double . unSeconds + +-- | converts a value of Time to seconds since midnight in UTC, using the +-- timezone that was valid in the timezone series on the given reference day +-- at the given number of seconds since midnight (note that this may lead to +-- strange effects for timezone changes not taking place at midnight) +toSeconds :: Time -> TimeZoneSeries -> Day -> Seconds +toSeconds (Time seconds _ _) tzseries refday = + Seconds $ seconds - timeZoneMinutes timezone * 60 where timezone = timeZoneFromSeries tzseries reftime + reftime = UTCTime refday (fromInteger $ toInteger seconds) + -- | Times in GTFS are given without timezone info, which is handled -- seperately (as an attribute of the stop / the agency). We attach that information diff --git a/lib/Persist.hs b/lib/Persist.hs index e463195..371ddd0 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -47,6 +47,8 @@ import Data.Vector (Vector) import Database.Persist.Postgresql (SqlBackend) import GHC.Generics (Generic) import Web.PathPieces (PathPiece) +import Fmt + newtype Token = Token UUID deriving newtype @@ -58,13 +60,14 @@ instance ToSchema Token where instance ToParamSchema Token where toParamSchema _ = toParamSchema (Proxy @String) +deriving newtype instance PersistField Seconds +deriving newtype instance PersistFieldSql Seconds +-- deriving newtype instance PathPiece Seconds +-- deriving newtype instance ToParamSchema Seconds + data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int deriving (ToJSON, FromJSON, Generic, Show, Read, Eq) derivePersistField "AmendmentStatus" --- instance FromHttpApiData AmendmentStatus where --- parseUrlPiece "Cancelled" = Right Cancelled --- parseUrlPiece "Added" = Right Added --- parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- | tokens which have been issued @@ -92,8 +95,8 @@ TrainAnchor json sql=tt_trip_anchor trip TripID day Day created UTCTime - when UTCTime - delay Int Maybe + when Seconds + delay Seconds Maybe msg Text Maybe deriving Show Generic Eq ToSchema diff --git a/lib/Server.hs b/lib/Server.hs index 1139ff8..759080c 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -52,7 +52,7 @@ import Server.Util (Service, ServiceM, runService, import Yesod (toWaiAppPlain) import Conferer (fetch, mkConfig) -import Extrapolation (Extrapolator (guessAnchor), +import Extrapolation (Extrapolator (..), LinearExtrapolator) import System.IO.Unsafe @@ -101,7 +101,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI pure token handleTrainPing ping = do running@Running{..} <- lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) - let anchor = guessAnchor @LinearExtrapolator gtfs running ping + let anchor = extrapolateAnchorFromPing @LinearExtrapolator gtfs running ping -- TODO: are these always inserted in order? runSql dbpool $ do insert ping diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 164d8ff..721d7df 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -28,7 +28,7 @@ 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) @@ -48,9 +48,12 @@ import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form +import Data.List.NonEmpty (nonEmpty) import GTFS import Persist +import Extrapolation (Extrapolator(..), LinearExtrapolator) +import Control.Monad (join) data ControlRoom = ControlRoom @@ -169,6 +172,8 @@ getTrainViewR trip day = do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] + anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] + <&> nonEmpty . (fmap entityVal) defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) @@ -188,6 +193,9 @@ getTrainViewR trip day = do <ol> $forall Stop{..} <- tripStops <li> #{stopArrival} #{stationName stopStation} + $maybe history <- anchors + $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day) + \ (#{delay}) <section> <h2>_{MsgAnnouncements} <ul> @@ -215,6 +223,7 @@ getTrainViewR trip day = do $else <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> |] + where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history getTripsViewR :: Handler Html @@ -323,3 +332,8 @@ instance ToMarkup Token where instance ToMessage Double where toMessage = T.pack . show + +instance ToMarkup Seconds where + toMarkup (Seconds s) = + if s > 0 then toMarkup ("+"+|s `div` 60|+"" :: Text) + else toMarkup (s `div` 60) |