diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/Frontend/SpaceTime.hs | 103 |
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 |