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