1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# 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, utctDay), diffUTCTime,
nominalDiffTimeToSeconds)
import qualified Data.Vector as V
import GHC.Float (int2Double)
import GHC.IO (unsafePerformIO)
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
-- | 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
-- 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)
extrapolateAtPosition = error "todo!"
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)
, trainAnchorMsg = Nothing
}
where Just trip = M.lookup runningTrip trips
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)
-- 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 $
minimumBy (compare `on` fst)
$ V.filter (\(dist,_) -> dist > 0)
$ fmap (\stop -> (distanceAlongLine line closestPoint (stationGeopos $ stopStation stop), stop)) tripStops
lastStop = snd $
maximumBy (compare `on` fst)
$ V.filter (\(dist,_) -> dist < 0)
$ fmap (\stop -> (distanceAlongLine line closestPoint (stationGeopos $ stopStation stop), stop)) tripStops
line = shapePoints tripShape
expectedTravelTime =
toSeconds (stopArrival nextStop) tzseries runningDay
- toSeconds (stopDeparture lastStop) tzseries runningDay
expectedProgress =
seconds2Double (utcToSeconds trainPingTimestamp runningDay
- toSeconds (stopDeparture lastStop) tzseries runningDay)
/ seconds2Double expectedTravelTime
-- 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)
distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double
distanceAlongLine line p1 p2 = along2 - along1
where along1 = along p1
along2 = along p2
along p@(x,y) = snd
$ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0)
$ V.take (index + 1) line
where index = fst $ minimumBy (compare `on` (euclid p . snd))
$ V.indexed line
-- | convert utc time to seconds on a day, with wrap-around
-- for trains that cross midnight.
utcToSeconds :: UTCTime -> Day -> Seconds
utcToSeconds time day =
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
where x = x1 - x2
y = y1 - y2
|
