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
190
191
192
193
194
195
|
{-# 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 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 1 day [ TicketDay ==. day ] >>= \case
Nothing -> notFound
Just widget -> defaultLayout [whamlet|
<h1>_{MsgSpaceTimeDiagram}
<section>
^{widget}
|]
mkSpaceTimeDiagramHandler :: Double -> Day -> [Filter Ticket] -> Handler (Maybe Widget)
mkSpaceTimeDiagramHandler scale day filter = do
tickets <- runDB $ selectList filter [ Asc TicketId ] >>= mapM (\ticket -> do
stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
arrival <- lift $ timeToPos scale day stopArrival
departure <- lift $ timeToPos scale day stopDeparture
pure (stop, arrival, departure))
anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
pure (ticket, stops, anchors))
case tickets of
[] ->
pure Nothing
_ ->
mkSpaceTimeDiagram scale day tickets
<&> Just
-- | Safety: tickets may not be empty
mkSpaceTimeDiagram
:: Double
-> Day
-> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
-> Handler Widget
mkSpaceTimeDiagram scale 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
station <- getJust (stopStation stop)
pure (station, stop { stopSequence = idx }))
let reference = stations
<&> \(_, stop) -> stop
let maxSequence = stopSequence (last reference)
let scaleSequence a = a * 100 / int2Double maxSequence
(minY, maxY) <- tickets
<&> (\(_,stops,_) -> stops)
& concat
& mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
<&> (\ys -> (minimum ys - 10, maximum ys + 30))
let timezone = head reference
& stopArrival
& GTFS.tzname
timeLines <- ([0,(double2Int $ 3600 / scale)..(24*3600)]
& mapM ((\a -> timeToPos scale 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}
-- trips
$forall (ticket, stops, anchors) <- tickets
<path
style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
d="M #{mkStopsline scaleSequence reference stops}"
>
<path
style="fill:none;stroke:red;stroke-width:0.3;"
d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
>
|]
mkStopsline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> Text
mkStopsline scaleSequence reference stops = stops
<&> mkStop
& T.concat
where mkStop (stop, arrival, departure) =
" "+|scaleSequence s|+","+|arrival|+" "
+|scaleSequence s|+","+|departure|+""
where s = mapSequenceWith reference stop & int2Double
mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
mkAnchorline scale scaleSequence reference stops anchors =
anchors
<&> (mkAnchor . entityVal)
& T.concat
where
mkAnchor TrainAnchor{..} =
" "+|scaleSequence transformed|+","
-- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+|secondsToPos scale trainAnchorWhen|+""
where
transformed = int2Double (mapSequence lastStop) + offset
offset =
abs (trainAnchorSequence - int2Double (stopSequence lastStop))
/ int2Double (stopSequence lastStop - stopSequence nextStop)
-- the below is necessary to flip if necessary (it can be either -1 or +1)
* int2Double (mapSequence lastStop - mapSequence nextStop)
mapSequence = mapSequenceWith reference
lastStop = stops
& filter (\(Stop{..},_,_) ->
int2Double stopSequence <= trainAnchorSequence)
& last
& \(stop,_,_) -> stop
nextStop = stops
& filter (\(Stop{..},_,_) ->
int2Double stopSequence > trainAnchorSequence)
& head
& \(stop,_,_) -> stop
-- | map a stop sequence number into the graph's space
mapSequenceWith :: [Stop] -> Stop -> Int
mapSequenceWith reference stop = filter
(\referenceStop -> stopStation referenceStop == stopStation stop) reference
& head
& stopSequence
-- | SAFETY: ignores time zones
secondsToPos :: Double -> Seconds -> Double
secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds
timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
timeToPos scale day time = do
settings <- getYesod <&> getSettings
tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)
|
