guess at future delays (horrible, incorrect, and unfinished)

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)