first commit

src/App.elm

@@ -0,0 +1,610 @@
+port module App exposing (..)
+
+import Browser
+import Browser.Events exposing (Visibility(..))
+import Dict exposing (Dict)
+import Html as H exposing (Html)
+import Html.Attributes as HA
+import Html.Events as HE
+import Json.Decode as JD
+import LatLonDistance exposing (lat_lon_distance, LatLon)
+import Svg as Svg
+import Svg.Attributes as SA
+import Svg.Events as SE
+import Task
+import Time
+import Tuple exposing (pair, first, second)
+
+
+port request_data : (String, Int) -> Cmd msg
+port request_location : () -> Cmd msg
+port receive_platform_data : (JD.Value -> msg) -> Sub msg
+port receive_location : (JD.Value -> msg) -> Sub msg
+
+main = Browser.document
+    { init = init
+    , update = update
+    , subscriptions = subscriptions
+    , view = view
+    }
+
+type alias Model = 
+  { stations : (List Station)
+  , lines : Dict String (List Stop)
+  , error : Maybe JD.Error
+  , current_station : Maybe String
+  , time : Time.Posix
+  , time_zone : Time.Zone
+  , window_visible : Visibility
+  , current_position : Maybe LatLon
+  }
+
+type alias Stop =
+  { station : String
+  , position: (Float, Float)
+  , latlon : (Float, Float)
+  }
+
+type alias Station =
+  { key : String
+  , name : String
+  , platforms : List Platform
+  , latlon : LatLon
+  }
+
+blank_station = 
+  { key = "???"
+  , name = "Unknown station" 
+  , platforms = []
+  , latlon = {lat = 0, lon = 0}
+  }
+
+type alias Platform =
+  { last_checked : Time.Posix
+  , platformNumber : Int
+  , direction : PlatformDirection
+  , angle : Float
+  , helperText : String
+  , trains : List TrainInfo
+  , station_key : String
+  }
+
+type alias TrainInfo =
+  { train : String
+  , last_event : TrainEvent
+  , last_event_location : (String, Int)
+  , last_event_time : String
+  , destination : String
+  , due_in : Int
+  , line : String
+  }
+
+type alias PlatformDataResponse =
+  { time : String
+  , station : String
+  , platformNumber : Int
+  , data : List TrainInfo
+  }
+
+type TrainEvent
+  = Departed
+  | Arrived
+  | ReadyToStart
+  | Approaching
+
+event_description : TrainEvent -> String
+event_description event = case event of
+  Departed -> "Departed"
+  Arrived -> "Arrived"
+  ReadyToStart -> "Starting"
+  Approaching -> "Approaching"
+
+type PlatformDirection
+  = In
+  | Out
+
+dir_arrow : PlatformDirection -> String
+dir_arrow d = case d of
+  In -> "←"
+  Out -> "→"
+
+decode_station : JD.Decoder Station
+decode_station =
+  JD.map4 Station
+    (JD.field "key" JD.string)
+    (JD.field "name" JD.string)
+    (JD.field "directions" (JD.dict JD.float) |> JD.andThen 
+      (\directions -> (JD.field "platforms" (JD.list (decode_platform directions))))
+    )
+    (JD.field "latlon" decode_latlon)
+
+decode_platform : Dict String Float -> JD.Decoder Platform
+decode_platform directions =
+  JD.map4
+    (\platformNumber direction helperText station_key -> 
+      let
+        angle = Dict.get (String.fromInt platformNumber) directions |> Maybe.withDefault 0
+      in
+        { last_checked = (Time.millisToPosix 0)
+        , platformNumber = platformNumber
+        , direction = direction
+        , helperText = helperText
+        , station_key = station_key
+        , trains = []
+        , angle = angle
+        }
+    )
+    (JD.field "platformNumber" JD.int)
+    (JD.field "direction" decode_direction)
+    (JD.field "helperText" JD.string)
+    (JD.field "station_key" JD.string)
+
+decode_direction : JD.Decoder PlatformDirection
+decode_direction =
+  JD.string |> JD.andThen
+    (\s -> case s of
+      "IN" -> JD.succeed In
+      "OUT" -> JD.succeed Out
+      _ -> JD.fail <| "Unrecognised direction " ++ s
+    )
+
+decode_stop : JD.Decoder Stop
+decode_stop =
+  JD.map3 Stop
+    (JD.field "key" JD.string)
+    (JD.field "map_position" (JD.map2 pair (JD.field "0" JD.float) (JD.field "1" JD.float)))
+    (JD.field "latlon" (JD.map2 pair (JD.field "0" JD.float) (JD.field "1" JD.float)))
+
+decode_train_info : Model -> JD.Decoder TrainInfo
+decode_train_info model =
+  JD.map7 TrainInfo
+    (JD.field "trn" JD.string)
+    (JD.field "lastEvent" decode_train_event)
+    (JD.field "lastEventLocation" (decode_event_location model))
+    (JD.field "lastEventTime" JD.string)
+    (JD.field "destination" JD.string)
+    (JD.field "dueIn" JD.int)
+    (JD.field "line" JD.string)
+
+decode_event_location : Model -> JD.Decoder (String, Int)
+decode_event_location model =
+  JD.string
+  |> JD.map (\s -> 
+    let
+      i = String.indices "Platform" s |> List.head |> Maybe.withDefault 0
+      name = String.slice 0 (i-1) s |> station_name_to_key model |> Maybe.withDefault ("???" ++ s)
+      platform_number = String.dropLeft (i+9) s |> String.toInt |> Maybe.withDefault 0
+    in
+      (name, platform_number)
+  )
+    
+decode_train_event : JD.Decoder TrainEvent
+decode_train_event =
+  JD.string |> JD.andThen
+    (\s -> case s of
+      "ARRIVED" -> JD.succeed Arrived
+      "DEPARTED" -> JD.succeed Departed
+      "READY_TO_START" -> JD.succeed ReadyToStart
+      "APPROACHING" -> JD.succeed Approaching
+      _ -> JD.fail <| "Unrecognised train event " ++ s
+    )
+
+decode_platform_data_response model =
+  JD.map4 PlatformDataResponse
+    (JD.field "time" JD.string)
+    (JD.field "station" JD.string)
+    (JD.field "platformNumber" JD.int)
+    (JD.field "data" (JD.list (decode_train_info model)))
+
+decode_geolocation : JD.Decoder LatLon
+decode_geolocation =
+  JD.map2 LatLon
+    (JD.at ["coords", "latitude"] JD.float)
+    (JD.at ["coords", "longitude"] JD.float)
+
+decode_latlon : JD.Decoder LatLon
+decode_latlon =
+  JD.map2 LatLon
+    (JD.field "0" JD.float)
+    (JD.field "1" JD.float)
+
+type Msg
+  = ReceivePlatformData JD.Value
+  | ReceiveLocation JD.Value
+  | TriggerTrainInfoRequest Station
+  | SetCurrentStation Station
+  | ClearCurrentStation
+  | UpdatePlatformData
+  | Tick Time.Posix
+  | SetTimeZone Time.Zone
+  | VisibilityChange Visibility
+  | RequestLocation
+  
+init : (JD.Value) -> (Model, Cmd Msg)
+init flags = 
+  let
+    model = init_model flags
+  in
+    ( model
+    , Cmd.batch
+        [ request_all_platform_data (station_with_key model (model.current_station |> Maybe.withDefault "MSN"))
+        , Task.perform SetTimeZone Time.here
+        ]
+    )
+
+blank_model = 
+  { stations = []
+  , lines = Dict.empty
+  , error = Nothing
+  , current_station = Just "MSN"
+  , time = Time.millisToPosix 0
+  , time_zone = Time.utc
+  , window_visible = Visible
+  , current_position = Nothing
+  }
+
+type alias Flags =
+  { stations : List Station
+  , lines : Dict String (List Stop)
+  , station : String
+  }
+  
+
+decode_flags =
+  JD.map3 Flags
+    (JD.field "stations" (JD.list decode_station))
+    (JD.field "lines" (JD.dict (JD.list decode_stop)))
+    (JD.oneOf
+      [ JD.field "station" JD.string
+      , JD.succeed "MSN"
+      ]
+    )
+
+init_model : JD.Value -> Model
+init_model flags = 
+  flags 
+  |> JD.decodeValue decode_flags 
+  |> (\r -> case r of
+    Ok flagdata -> { blank_model | stations = flagdata.stations, lines = flagdata.lines, current_station = Just flagdata.station }
+    Err err -> { blank_model | error = Just (Debug.log "error" err) }
+  )
+
+nocmd model = (model, Cmd.none)
+
+request_all_platform_data station = 
+  Cmd.batch (List.map (\p -> request_data (p.station_key, p.platformNumber)) station.platforms)
+
+update msg model = case msg of
+  TriggerTrainInfoRequest station -> 
+    ( model
+    , request_all_platform_data station
+    )
+  
+  ReceivePlatformData data -> 
+    case JD.decodeValue (decode_platform_data_response model) data of
+      Err err -> {model | error = Just err } |> nocmd
+      Ok d -> add_platform_data d model |> nocmd
+
+  RequestLocation -> (model, request_location ())
+
+  ReceiveLocation data ->
+    case JD.decodeValue (decode_geolocation) data of
+      Err err -> {model | error = Just (Debug.log "err" err) } |> nocmd
+      Ok latlon -> 
+        let
+          closest_stations = geo_closest_stations model latlon
+          nstation = case List.head closest_stations of
+            Nothing -> model.current_station
+            Just (s,_) -> Just s.key
+        in
+          { model | current_position = Just latlon, current_station = nstation } |> nocmd
+
+  SetCurrentStation station -> { model | current_station = Just station.key } |> update (TriggerTrainInfoRequest station)
+
+  ClearCurrentStation -> 
+    { model | current_station = Nothing } |> nocmd
+
+  UpdatePlatformData -> 
+    ( model
+    , case (model.window_visible, model.current_station) of
+      (Visible, Just s) -> station_with_key model s |> request_all_platform_data
+      _ -> Cmd.none
+    )
+
+  Tick time -> { model | time = time } |> nocmd
+
+  SetTimeZone zone -> { model | time_zone = zone } |> nocmd
+
+  VisibilityChange visible -> { model | window_visible = visible } |> nocmd
+
+add_platform_data d model =
+  let
+    nstations = 
+      model.stations 
+      |> List.map (\s -> 
+        if s.key == d.station then 
+          { s | platforms = List.map (\p -> if p.platformNumber == d.platformNumber then { p | trains = d.data, last_checked = model.time } else p) s.platforms}
+        else s
+        )
+    in
+      { model | stations = nstations }
+
+subscriptions model = 
+  Sub.batch
+    [ receive_platform_data ReceivePlatformData
+    , receive_location ReceiveLocation
+    , Time.every (1000 * 60) (\_ -> UpdatePlatformData)
+    , Time.every 100 Tick
+    , Browser.Events.onVisibilityChange VisibilityChange
+    ]
+
+view : Model -> Browser.Document Msg
+view model = 
+  let
+    current_station = model.current_station |> Maybe.map (station_with_key model)
+  
+    next_trains =
+      current_station 
+      |> Maybe.map (\s ->
+             s.platforms 
+          |> List.filterMap (\p -> p.trains |> List.head |> Maybe.map (\t -> "P" ++ (String.fromInt p.platformNumber) ++ ": " ++ (String.fromInt t.due_in)))
+          |> String.join ", "
+          |> \times -> times ++ " @ " ++ s.name
+         )
+      |> Maybe.withDefault ""
+  
+    view_station open station =
+      H.article
+        [ HE.on "toggle" (
+            JD.succeed (TriggerTrainInfoRequest station)
+          )
+        , HA.class "station"
+        ]
+        [ H.ol
+          [ HA.class "platforms"]
+          (List.map (view_platform station) station.platforms)
+        ]
+
+    format_time t =
+      let
+        zone = model.time_zone
+        hour = Time.toHour zone t
+        minute = Time.toMinute zone t
+        pad = String.fromInt >> String.padLeft 2 '0'
+      in
+        (pad hour) ++ ":" ++ (pad minute)
+
+    closest_stations = case model.current_position of
+      Nothing -> []
+      Just pos -> geo_closest_stations model pos
+    
+    view_platform : Station -> Platform -> Html Msg
+    view_platform station platform =
+      H.li
+        [ HA.value <| String.fromInt platform.platformNumber
+        ]
+        [ table
+            [ H.a 
+              [ HA.href <| "https://metro-rti.nexus.org.uk/api/times/" ++ station.key ++ "/" ++ (String.fromInt platform.platformNumber)
+              , HA.target "_blank"
+              ] 
+              [H.text <|
+                   "Platform "
+                ++ (String.fromInt platform.platformNumber)
+                ++ ": " 
+                ++ platform.helperText
+              ]
+            , H.small [ HA.class "last-checked" ] [ H.text <| format_time platform.last_checked]
+            ]
+            ["Due", "Destination", "Last seen", "Event", "Train"]
+            (List.map (\t -> 
+              let
+                last_station = station_with_key model (first t.last_event_location)
+                time_expected = 
+                  (Time.posixToMillis model.time) + (1000 * 60 * t.due_in)
+                  |> Time.millisToPosix
+
+                due_string =
+                  if t.due_in > 1 then
+                    (String.fromInt t.due_in) ++ " (" ++ format_time time_expected ++ ")"
+                  else
+                    "here"
+              in
+                [ due_string
+                , t.destination
+                , last_station.name
+                , event_description t.last_event
+                , t.train
+                ]
+              ) platform.trains
+            )
+        ]
+    
+
+  in
+
+  {
+    title = "Metro info (" ++ next_trains ++ ")",
+    body = 
+      [ H.div
+        [ HA.id "controls" ]
+        [ H.label
+            [ HA.for "station" ]
+            [ H.text "Trains from"]
+        , H.select
+          [ HA.id "station"
+          , HA.value <| Maybe.withDefault "" <| model.current_station
+          , HE.on "input"
+              ( JD.field "target" (JD.field "value" JD.string)
+               |>  JD.andThen 
+                  (   station_with_key model 
+                   >> SetCurrentStation >> JD.succeed
+                  )
+              )
+          ]
+          (List.map 
+            (\s -> 
+              H.option 
+                [ HA.value s.key] 
+                [H.text s.name]
+            )
+            (List.sortBy .name model.stations)
+          )
+        , H.button
+          [ HA.type_ "button"
+          , HE.onClick UpdatePlatformData
+          ]
+          [ H.text "⟳" ]
+
+        , H.button
+          [ HA.type_ "button"
+          , HE.onClick RequestLocation
+          ]
+          [ H.text "🧭" ]
+
+        , H.a
+          [ HA.href "https://www.nexus.org.uk/metro/updates"
+          , HA.target "_blank"
+          ]
+          [ H.text "Disruptions" ]
+        ]
+      , case current_station of
+          Nothing -> H.text ""
+          Just station -> view_station True station
+      , view_map model
+
+      , H.footer
+        []
+        [ H.p
+          []
+          [ H.text "Made unofficially by "
+          , H.a [ HA.href "https://somethingorotherwhatever.com" ] [ H.text "clp" ]
+          , H.text ". Uses data from the "
+          , H.a [ HA.href "https://github.com/danielgjackson/metro-rti" ] [ H.text "Tyne and Wear Metro Real-Time Information API" ]
+          , H.text "."
+          ]
+        ]
+      ]
+  }
+
+station_position : Model -> String -> String -> Maybe (Float, Float)
+station_position model line station_key =
+  Dict.get line model.lines
+  |> Maybe.andThen (List.filter (\s -> s.station == station_key) >> List.head >> Maybe.map .position)
+
+platform_direction : Model -> String -> Int -> Maybe Float
+platform_direction model station_key platform_number =
+  model.stations |> List.filter (.key >> (==) station_key) |> List.head |> Maybe.andThen (.platforms >> List.filter (.platformNumber >> (==) platform_number) >> List.head) |> Maybe.map (.angle)
+
+station_name_to_key : Model -> String -> Maybe String
+station_name_to_key model name =
+  model.stations
+  |> List.map (\s -> (s.name, s.key))
+  |> Dict.fromList
+  |> Dict.get name
+
+station_with_key : Model -> String -> Station
+station_with_key model key = model.stations |> List.filter (.key >> (==) key) |> List.head |> Maybe.withDefault { blank_station | key = key }
+
+geo_closest_stations model pos = model.stations |> List.map (\s -> (s, lat_lon_distance pos s.latlon)) |> List.sortBy second
+
+all_trains : Model -> List TrainInfo
+all_trains model = 
+  List.concatMap (.platforms >> List.concatMap (.trains)) (List.filter (\s -> model.current_station == Just s.key) model.stations)
+  |> List.sortBy (\t -> (t.train, t.last_event_time))
+
+view_map model =
+  let
+    trains = 
+      all_trains model |> List.filterMap (\t -> 
+        let
+          (key, platformNumber) = t.last_event_location
+          position = station_position model t.line key
+          direction = platform_direction model key platformNumber |> Maybe.withDefault 0
+        in
+          position
+          |> Maybe.map (\(x,y) ->
+            Svg.g
+              [ SA.class "train"
+              , SA.transform <| "translate(" ++ (String.fromFloat x)++" "++(String.fromFloat y)++")"
+              ]
+              [ Svg.circle
+                [ SA.r "5"
+                ] 
+                []
+              , Svg.path 
+                [ SA.d "M 0 0 L 8 0 M 5 2 L 8 0 L 5 -2"
+                , SA.fill "none"
+                , SA.stroke "black"
+                , SA.strokeWidth "5"
+                , SA.transform <| "rotate(" ++ (String.fromFloat direction) ++ ")"
+                ]
+                [] 
+              , Svg.text_
+                [ SA.fontSize "4"
+                , SA.fill "white"
+                , SA.textAnchor "middle"
+                , SA.dominantBaseline "middle"
+                ]
+                [ Svg.text t.train ]
+              ]
+          )
+        )
+
+    lines : List (String, List Stop)
+    lines = 
+         model.lines 
+      |> Dict.toList 
+
+    stations =
+      lines
+      |> List.concatMap (\(line,stops) -> 
+             stops 
+          |> List.map (\stop -> station_with_key model stop.station |> (\s ->
+              Svg.circle
+                [ SA.r "6" 
+                , SA.cx <| String.fromFloat (first stop.position)
+                , SA.cy <| String.fromFloat (second stop.position)
+                , SA.fillOpacity <| if model.current_station == Just stop.station then "0.5" else "0.01"
+                , SA.fill "blue"
+                , SE.onClick (SetCurrentStation s)
+                ]
+                []
+          ))
+        )
+  in
+    H.div
+      [ HA.id "map-container" ]
+      [ Svg.svg
+        [ HA.attribute "viewBox" "0 0 595.275 280.63" 
+        , HA.id "map"
+        ]
+        [ Svg.use 
+          [ HA.attribute "href" "metro_map.svg#map"
+          ]
+          []
+        , Svg.g [] (trains)
+        , Svg.g [] (stations)
+        ]
+      ]
+
+table : List (Html Msg) -> List String -> List (List String) -> Html Msg
+table caption headers rows =
+  H.table
+    []
+    [ H.caption 
+      []
+      caption
+    , H.thead
+      []
+      [H.tr [] (List.map (\h -> H.th [] [H.text h]) headers)]
+    , H.tbody
+      []
+      (   (List.map (\row -> H.tr [] (List.map (\c -> H.td [] [H.text c]) row)) rows)
+       |> pad_list 4 (H.tr [HA.class "empty"] (List.map (\_ -> H.td [] [ H.text "-"]) headers))
+      )
+    ]
+
+pad_list : Int -> a -> List a -> List a
+pad_list n blank list = 
+  List.append list (List.repeat (n - (List.length list)) blank)

src/LatLonDistance.elm

@@ -0,0 +1,50 @@
+module LatLonDistance exposing (lat_lon_distance, LatLon)
+
+type alias LatLon = { lat : Float, lon : Float }
+
+lat_lon_distance : LatLon -> LatLon -> Float
+lat_lon_distance p1 p2 =
+  let
+    a = 6378137.0
+    b = 6356752.314245
+    f = 1 / 298.257223563
+    lat1 = degrees p1.lat
+    lat2 = degrees p2.lat
+    lon1 = degrees p1.lon
+    lon2 = degrees p2.lon
+
+    dlon = (lon2 - lon1)
+
+    tanU1 = (1-f) * (tan lat1)
+    cosU1 = 1 / (sqrt (1 + tanU1 * tanU1))
+    sinU1 = tanU1 * cosU1
+
+    tanU2 = (1-f) * (tan lat2)
+    cosU2 = 1 / (sqrt (1 + tanU2*tanU2))
+    sinU2 = tanU2 * cosU2
+
+    approx lon =
+      let
+        sinlon = sin lon
+        coslon = cos lon
+        sinSqsigma = (cosU2*sinlon) * (cosU2*sinlon) + (cosU1*sinU2-sinU1*cosU2*coslon) ^ 2
+        sinsigma = sqrt sinSqsigma
+        cossigma = sinU1*sinU2 + cosU1*cosU2*coslon
+        sigma = atan2 sinsigma cossigma
+        sinalpha = cosU1 * cosU2 * sinlon / sinsigma
+        cosSqalpha = 1 - sinalpha*sinalpha
+        cos2sigma_m = cossigma - 2*sinU1*sinU2/cosSqalpha
+        c = f/16*cosSqalpha*(4+f*(4-3*cosSqalpha))
+        lon_ = dlon + (1-c) * f * sinalpha * (sigma + c*sinsigma*(cos2sigma_m+c*cossigma*(-1+2*cos2sigma_m*cos2sigma_m)))
+        
+        uSq = cosSqalpha * (a*a - b*b) / (b*b)
+        biga = 1 + uSq/16384*(4096+uSq*(-768+uSq*(320-175*uSq)))
+        bigb = uSq/1024 * (256+uSq*(-128+uSq*(74-47*uSq)))
+        deltasigma = bigb*sinsigma*(cos2sigma_m+bigb/4*(cossigma*(-1+2*cos2sigma_m*cos2sigma_m)-bigb/6*cos2sigma_m*(-3+4*sinsigma*sinsigma)*(-3+4*cos2sigma_m*cos2sigma_m)))
+        
+        s = b*biga*(sigma-deltasigma)
+        
+      in
+        if abs (lon - lon_) > 1e-12 then (approx lon_) else s
+  in
+    approx dlon