aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Extrapolation.hs69
-rw-r--r--lib/GTFS.hs34
-rw-r--r--lib/Persist.hs15
-rw-r--r--lib/Server.hs4
-rw-r--r--lib/Server/ControlRoom.hs16
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)