aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend/SpaceTime.hs
blob: 878a62721d57038ef63335a8edb344690e29173f (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
{-# 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)