diff options
Diffstat (limited to 'lib/Extrapolation.hs')
| -rw-r--r-- | lib/Extrapolation.hs | 69 |
1 files changed, 42 insertions, 27 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 |