aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend/SpaceTime.hs
blob: 16e820537c2af75baf9a8e5931be5c6345e6fbb9 (plain)
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)