Server.Frontend.SpaceTime: fix lots of bugs

also make the code generally look nicer. Turns out I made a lot more
fragile assumptions than I thought I did.

1 files changed, 54 insertions, 49 deletions

diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
index 878a627..87b9ace 100644
--- a/lib/Server/Frontend/SpaceTime.hs
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -20,7 +20,6 @@ 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))
@@ -48,7 +47,7 @@ getSpaceTimeDiagramR = do
 
 mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget)
 mkSpaceTimeDiagramHandler day = do
-  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketId ] >>= mapM (\ticket -> do
     stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
       arrival <- lift $ timeToPos day stopArrival
       departure <- lift $ timeToPos day stopDeparture
@@ -66,7 +65,7 @@ mkSpaceTimeDiagramHandler day = do
 -- | Safety: tickets may not be empty
 mkSpaceTimeDiagram
   :: Day
-  -> [(a, [(Stop, Double, Double)], [Entity TrainAnchor])]
+  -> [(Entity Ticket, [(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
@@ -77,10 +76,12 @@ mkSpaceTimeDiagram day tickets = do
     & sortOn stopSequence
     & zip [0..]
     & mapM (\(idx, stop) -> do
-          s <- getJust (stopStation stop)
-          pure (stopStation stop, s, stop { stopSequence = idx }))
+          station <- getJust (stopStation stop)
+          pure (station, stop { stopSequence = idx }))
 
-  let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations))
+  let reference = stations
+       <&> \(_, stop) -> stop
+  let maxSequence = stopSequence (last reference)
   let scaleSequence a = a * 100 / int2Double maxSequence
 
 
@@ -90,8 +91,7 @@ mkSpaceTimeDiagram day tickets = do
        & mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop))
        <&> (\ys -> (minimum ys - 10, maximum ys + 30))
 
-  let timezone = head stations
-        & (\(_,_,stop) -> stop)
+  let timezone = head reference
         & stopArrival
         & GTFS.tzname
 
@@ -112,7 +112,7 @@ mkSpaceTimeDiagram day tickets = do
              <tspan x="-5" y="#{y + 0.1}">#{time}
 
          -- vertical lines per station
-         $forall (_, station, Stop{..}) <- stations
+         $forall (station, Stop{..}) <- stations
            <path
              style="fill:none;stroke:#79797a;stroke-width:0.3"
              d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
@@ -123,65 +123,70 @@ mkSpaceTimeDiagram day tickets = do
                y="#{scaleSequence (int2Double stopSequence) - 0.5}"
                >#{stationName station}
 
-         -- static (scheduled) trip routes
+         -- trips
          $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}"
+             d="M #{mkStopsline scaleSequence reference stops}"
              >
            <path
              style="fill:none;stroke:red;stroke-width:0.3;"
-             d="M #{mkAnchorline scaleSequence stations anchors}"
+             d="M #{mkAnchorline scaleSequence reference stops anchors}"
              >
         |]
 
-mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text
-mkStopsline scaleSequence stations stops = stops
+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 = 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
+          where s = mapSequenceWith reference stop & int2Double
+
+mkAnchorline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scaleSequence reference stops 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!
+  where
+    mkAnchor TrainAnchor{..} =
+      " "+|scaleSequence transformed|+","
+      -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+      +|secondsToPos 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 :: Seconds -> Double
 secondsToPos = (/ 600) . int2Double . GTFS.unSeconds
 
-
 timeToPos :: Day -> GTFS.Time -> Handler Double
 timeToPos day time = do
   settings <- getYesod <&> getSettings