space time diagrams: real time & time zones

3 files changed, 178 insertions, 86 deletions

diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
index 3beb9e0..cec4fa7 100644
--- a/lib/Server/Frontend.hs
+++ b/lib/Server/Frontend.hs
@@ -5,8 +5,8 @@ module Server.Frontend (Frontend(..), Handler) where
 import           Server.Frontend.Gtfs
 import           Server.Frontend.OnboardUnit
 import           Server.Frontend.Routes
-import           Server.Frontend.Tickets
 import           Server.Frontend.SpaceTime
+import           Server.Frontend.Tickets
 
 import           Yesod
 import           Yesod.Auth
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
index 307e795..878a627 100644
--- a/lib/Server/Frontend/SpaceTime.hs
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -1,104 +1,189 @@
 {-# LANGUAGE DataKinds       #-}
 {-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE MultiWayIf      #-}
 {-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module Server.Frontend.SpaceTime (getSpaceTimeDiagramR) where
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
 
-import Server.Frontend.Routes
+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 qualified Data.Text as T
+import           Text.Read              (readMaybe)
 import           Yesod
-import Text.Read (readMaybe)
-import Data.Time (getCurrentTime, UTCTime (..))
-import Persist
-import Data.Function ((&), on)
-import Data.List
-import Data.Coerce (coerce)
-import Control.Monad (when, forM)
-import GHC.Float (int2Double)
-import Fmt ((|+), (+|))
-import Data.Maybe (catMaybes, mapMaybe)
-import GTFS (Seconds(unSeconds))
 
 getSpaceTimeDiagramR :: Handler Html
 getSpaceTimeDiagramR = do
-
   req <- getRequest
-
   day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of
-    Just day -> pure  day
+    Just day -> pure day
     Nothing  -> liftIO $ getCurrentTime <&> utctDay
 
-  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
-    stops <- selectList [StopTicket ==. entityKey ticket] []
-    pure (ticket, stops))
-
-
-  -- TODO: this should be a nicer error message
-  when (null tickets)
-    notFound
+  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 snd tickets
-        & maximumBy (compare `on` length)
-        & fmap entityVal
-        & sortOn stopSequence
-        & mapM (\stop -> do
-              s <- getJust (stopStation stop)
-              pure (stopStation stop, s, stop))
+  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 = int2Double a * 100 / int2Double maxSequence
+  let scaleSequence a = a * 100 / int2Double maxSequence
 
-  let (minY, maxY) = tickets
-       <&> snd
+
+  (minY, maxY) <- tickets
+       <&> (\(_,stops,_) -> stops)
        & concat
-       <&> (timeToPos . stopDeparture . entityVal)
-       & (\ys -> (minimum ys - 20, maximum ys + 20))
+       & mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
+       <&> (\ys -> (minimum ys - 10, maximum ys + 30))
+
+  let timezone = head stations
+        & (\(_,_,stop) -> stop)
+        & stopArrival
+        & GTFS.tzname
 
-  defaultLayout $ do
-    [whamlet|
-       <h1>_{MsgSpaceTimeDiagram}
+  timeLines <- ([0,3600..(24*3600)]
+    & mapM ((\a -> timeToPos day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+    <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
 
-       <section><svg viewBox="-2 #{minY} 106 #{maxY - minY}" width="100%">
+  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 stopSequence},#{minY} #{scaleSequence stopSequence},#{maxY}"
+             d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
              >
-           <text style="font-size:2pt;" transform="rotate(90)">
+           <text style="font-size:2pt;" transform="rotate(-90)">
              <tspan
-               x="#{minY + 3}"
-               y="#{0 - (scaleSequence stopSequence + 0.5)}"
+               x="#{0 - maxY}"
+               y="#{scaleSequence (int2Double stopSequence) - 0.5}"
                >#{stationName station}
-         $forall (ticket, stops) <- tickets
+
+         -- static (scheduled) trip routes
+         $forall (ticket, stops, anchors) <- tickets
            <path
-             style="fill:none;stroke:blueviolet;stroke-width:0.3"
+             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 :: (Int -> Double) -> [(StationId, Station, Stop)] -> [Entity Stop] -> Text
+mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
 mkStopsline scaleSequence stations stops = stops
-  <&> (mkStop . entityVal)
+  <&> mkStop
   & T.concat
-  where mkStop stop = " "+|scaleSequence s|+","+|timeToPos (stopArrival stop)|+" "
-                             +|scaleSequence s|+","+|timeToPos (stopDeparture stop)|+""
+  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
+
 
--- TODO: ignores time zones!
-timeToPos = (\a -> a / 500) . int2Double . GTFS.timeSeconds
--- timeToPos time = unSeconds $ GTFS.toSeconds time _ _
+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)
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 43f24aa..ef80d42 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -15,39 +15,41 @@ module Server.Frontend.Tickets
 
 import           Server.Frontend.Routes
 
-import           Config                   (ServerConfig (..), UffdConfig (..))
-import           Control.Monad            (forM, forM_, join)
-import           Control.Monad.Extra      (maybeM)
-import           Control.Monad.IO.Class   (MonadIO (liftIO))
-import           Data.Coerce              (coerce)
-import           Data.Function            (on, (&))
-import           Data.Functor             ((<&>))
-import           Data.List                (lookup, nubBy)
-import           Data.List.NonEmpty       (nonEmpty)
-import           Data.Map                 (Map)
-import qualified Data.Map                 as M
-import           Data.Maybe               (catMaybes, fromJust, isJust)
-import           Data.Text                (Text)
-import qualified Data.Text                as T
-import           Data.Time                (UTCTime (..), addDays,
-                                           getCurrentTime, utctDay)
-import           Data.Time.Calendar       (Day)
-import           Data.Time.Format.ISO8601 (iso8601Show)
-import           Data.UUID                (UUID)
-import qualified Data.UUID                as UUID
-import qualified Data.Vector              as V
-import           Extrapolation            (Extrapolator (..),
-                                           LinearExtrapolator (..))
-import           Fmt                      ((+|), (|+))
-import           GHC.Float                (int2Double)
+import           Config                    (ServerConfig (..), UffdConfig (..))
+import           Control.Monad             (forM, forM_, join)
+import           Control.Monad.Extra       (maybeM)
+import           Control.Monad.IO.Class    (MonadIO (liftIO))
+import           Data.Coerce               (coerce)
+import           Data.Function             (on, (&))
+import           Data.Functor              ((<&>))
+import           Data.List                 (lookup, nubBy)
+import           Data.List.NonEmpty        (nonEmpty)
+import           Data.Map                  (Map)
+import qualified Data.Map                  as M
+import           Data.Maybe                (catMaybes, fromJust, isJust)
+import           Data.Text                 (Text)
+import qualified Data.Text                 as T
+import           Data.Time                 (UTCTime (..), addDays,
+                                            getCurrentTime, utctDay)
+import           Data.Time.Calendar        (Day)
+import           Data.Time.Format.ISO8601  (iso8601Show)
+import           Data.UUID                 (UUID)
+import qualified Data.UUID                 as UUID
+import qualified Data.Vector               as V
+import           Extrapolation             (Extrapolator (..),
+                                            LinearExtrapolator (..))
+import           Fmt                       ((+|), (|+))
+import           GHC.Float                 (int2Double)
 import qualified GTFS
-import           Numeric                  (showFFloat)
+import           Numeric                   (showFFloat)
 import           Persist
-import           Server.Util              (Service, secondsNow)
-import           Text.Read                (readMaybe)
+import           Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
+                                            mkSpaceTimeDiagramHandler)
+import           Server.Util               (Service, secondsNow)
+import           Text.Read                 (readMaybe)
 import           Yesod
 import           Yesod.Auth
-import           Yesod.Auth.Uffd          (UffdUser (..), uffdClient)
+import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)
 
 
 getTicketsR :: Handler Html
@@ -61,6 +63,8 @@ getTicketsR = do
       Just day -> (day, day == today)
       Nothing  -> (today, True)
 
+  maybeSpaceTime <- mkSpaceTimeDiagramHandler day
+
   let prevday = (T.pack . iso8601Show . addDays (-1))  day
   let nextday = (T.pack . iso8601Show . addDays 1) day
   gtfs <- getYesod <&> getGtfs
@@ -94,6 +98,9 @@ $maybe name <- mdisplayname
          : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
    $if null tickets
      <li style="text-align: center"><em>(_{MsgNone})</em>
+$maybe spaceTime <- maybeSpaceTime
+  <section>
+    ^{spaceTime}
 <section>
   <h2>_{MsgAccordingToGtfs}
   <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>