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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
import Server.Frontend.Routes
import Control.Monad (forM, when)
import Data.Coerce (coerce)
import Data.Function (on, (&))
import Data.Functor ((<&>))
import Data.Graph (path)
import Data.List
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (Day, UTCTime (..), getCurrentTime)
import qualified Data.Vector as V
import Debug.Trace (trace)
import Fmt ((+|), (|+))
import GHC.Float (double2Int, int2Double)
import GTFS (Seconds (unSeconds))
import qualified GTFS
import Persist
import Server.Util (getTzseries)
import Text.Blaze.Html (Html)
import Text.Read (readMaybe)
import Yesod
getSpaceTimeDiagramR :: Handler Html
getSpaceTimeDiagramR = do
req <- getRequest
day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of
Just day -> pure day
Nothing -> liftIO $ getCurrentTime <&> utctDay
mkSpaceTimeDiagramHandler day >>= \case
Nothing -> notFound
Just widget -> defaultLayout [whamlet|
<h1>_{MsgSpaceTimeDiagram}
<section>
^{widget}
|]
mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
mkSpaceTimeDiagramHandler day = do
tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
arrival <- lift $ timeToPos day stopArrival
departure <- lift $ timeToPos day stopDeparture
pure (stop, arrival, departure))
anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
pure (ticket, stops, anchors))
case tickets of
[] ->
pure Nothing
_ ->
mkSpaceTimeDiagram day tickets
<&> Just
-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
:: Day
-> [(a, [(Stop, Double, Double)], [Entity TrainAnchor])]
-> Handler Widget
mkSpaceTimeDiagram day tickets = do
-- we take the longest trip of the day. This will lead to unreasonable results
-- if there's more than one shape (this whole route should probably take a shape id tbh)
stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets
& maximumBy (compare `on` length)
& fmap (\(stop, _, _) -> stop)
& sortOn stopSequence
& zip [0..]
& mapM (\(idx, stop) -> do
s <- getJust (stopStation stop)
pure (stopStation stop, s, stop { stopSequence = idx }))
let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations))
let scaleSequence a = a * 100 / int2Double maxSequence
(minY, maxY) <- tickets
<&> (\(_,stops,_) -> stops)
& concat
& mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
<&> (\ys -> (minimum ys - 10, maximum ys + 30))
let timezone = head stations
& (\(_,_,stop) -> stop)
& stopArrival
& GTFS.tzname
timeLines <- ([0,3600..(24*3600)]
& mapM ((\a -> timeToPos day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
<&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
pure [whamlet|
<svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%">
-- horizontal lines per hour
$forall (y, time) <- timeLines
<path
style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1"
d="M 0,#{y} 100,#{y}"
>
<text style="font-size:1pt;">
<tspan x="-5" y="#{y + 0.1}">#{time}
-- vertical lines per station
$forall (_, station, Stop{..}) <- stations
<path
style="fill:none;stroke:#79797a;stroke-width:0.3"
d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
>
<text style="font-size:2pt;" transform="rotate(-90)">
<tspan
x="#{0 - maxY}"
y="#{scaleSequence (int2Double stopSequence) - 0.5}"
>#{stationName station}
-- static (scheduled) trip routes
$forall (ticket, stops, anchors) <- tickets
<path
style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
d="M #{mkStopsline scaleSequence stations stops}"
>
<path
style="fill:none;stroke:red;stroke-width:0.3;"
d="M #{mkAnchorline scaleSequence stations anchors}"
>
|]
mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
mkStopsline scaleSequence stations stops = stops
<&> mkStop
& T.concat
where mkStop (stop, arrival, departure) =
" "+|scaleSequence s|+","+|arrival|+" "
+|scaleSequence s|+","+|departure|+""
where s = mapMaybe
(\(stationId, _, res) ->
if stationId == stopStation stop then Just res else Nothing) stations
& head
& stopSequence
& int2Double
mkAnchorline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [Entity TrainAnchor] -> Text
mkAnchorline scaleSequence stations anchors = anchors
<&> (mkAnchor . entityVal)
& T.concat
where mkAnchor anchor =
" "+|scaleSequence (transSequence (trainAnchorSequence anchor))|+","
-- this use of secondsToPos is correct; when saves in the correct timezone already
+|secondsToPos (trainAnchorWhen anchor)|+""
where transSequence :: Double -> Double
transSequence a = int2Double (mapSequence lastStop) + percent
where percent = abs (a - int2Double (stopSequence lastStop))
/ abs (int2Double (stopSequence lastStop - stopSequence nextStop))
mapSequence :: Stop -> Int
mapSequence stop = mapMaybe
(\(stationId, _, res) ->
if stationId == stopStation stop then Just res else Nothing) stations
& head
& stopSequence
lastStop = (\(_,_,stop) -> stop) (stations !! lastIndex)
nextStop = (\(_,_,stop) -> stop) (stations !! (lastIndex + 1))
lastIndex = if
| rounded < 0 -> 0
| rounded > length stations - 1 -> length stations - 2
| otherwise -> rounded
where rounded = floor (trainAnchorSequence anchor)
-- TODO: these ignore time zones!
secondsToPos :: Seconds -> Double
secondsToPos = (/ 600) . int2Double . GTFS.unSeconds
timeToPos :: Day -> GTFS.Time -> Handler Double
timeToPos day time = do
settings <- getYesod <&> getSettings
tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
pure $ secondsToPos (GTFS.toSeconds time tzseries day)
|
