souplesse/frontend/src/Main.elm

module Main exposing (view)

import Browser
import Browser.Navigation as Nav
import Html exposing (Html, button, div, span, text, img)
import Html.Attributes as H exposing (src, style, width, height)
import Html.Events exposing (onClick, on)
import Html.Events.Extra.Pointer as Pointer
import Maybe exposing (Maybe)
import Lib exposing(..)
import List.Extra exposing(find)
import Json.Decode as D
import Http
import Point exposing(Point, Pos ,decoder)
import Svg exposing (Svg, svg, rect, g, polyline, line)
import Svg.Attributes as S exposing
    ( viewBox
    , preserveAspectRatio
    , transform
    , x, y
    , x1, y1 , x2, y2
    , fill
    , stroke, strokeWidth, strokeOpacity)
import Time
import Url.Parser exposing (Parser, (<?>), int, map, s, string)
import Url.Parser.Query as Query
import Url exposing (Url)

type Route = Timeline (Maybe Int) (Maybe Int)

routeParser : Parser (Route -> a) a
routeParser =
  map Timeline (s "timeline" <?> Query.int "start" <?> Query.int "duration")


-- MAIN


main =
  Browser.application
      { init = init
      , update = update
      , subscriptions = subscriptions
      , onUrlRequest = \ _ ->  NewUrlRequest
      , onUrlChange = \ _ -> UrlChanged
      , view = view }

-- MATHS

-- Coordinates in a Mercator projection
type alias Coord = { x: Float, y: Float }

-- zoom level
type alias ZoomLevel = Int
type FineZoomLevel = FineZoomLevel Int

zoomStep = 8

toZoom : FineZoomLevel -> ZoomLevel
toZoom (FineZoomLevel f) = f // zoomStep


incZoom : FineZoomLevel -> Int -> FineZoomLevel
incZoom (FineZoomLevel z) delta =
    FineZoomLevel (clamp 0 (20 * zoomStep) (z + delta))

type alias TileNumber = { x: Int, y: Int }

-- project lat/long to co-ordinates based on pseudocode at
-- https://wiki.openstreetmap.org/wiki/Slippy_map_tilenames#Zoom_levels

sec x = 1 / (cos x)

toCoord : Pos -> Coord
toCoord pos =
    let
        lat_rad = pos.lat * pi / 180
        x = (pos.lon + 180) / 360
        y = (1 - (logBase e ((tan lat_rad) + (sec lat_rad))) / pi) / 2
    in
        Coord x y

pixelsToCoord z (x,y) =
    let x_float = toFloat x / toFloat ( 2 ^ (z + 8))
        y_float = toFloat y / toFloat ( 2 ^ (z + 8))
    in Coord x_float y_float

reflect : Coord -> Coord
reflect c = Coord -c.x -c.y

-- translate : a -> a -> a
translate base offset =
    { base | x = (base.x + offset.x), y = (base.y + offset.y) }

translatePixels : Coord -> ZoomLevel -> (Int, Int) -> Coord
translatePixels old z (x, y) = translate old (pixelsToCoord z (x, y))


tileCovering : Coord -> ZoomLevel -> TileNumber
tileCovering c z =
    TileNumber (truncate (toFloat (2 ^ z) * c.x)) (truncate (toFloat (2 ^ z) * c.y))

pixelFromCoord : Coord -> ZoomLevel -> (Int, Int)
pixelFromCoord c z =
    let {x,y} = tileCovering c (z + 8)
    in (x,y)

boundingTiles : Coord -> ZoomLevel -> Int -> Int -> (TileNumber, TileNumber)
boundingTiles centre z width height =
    -- find the tiles needed to cover the area (`width` x `height`)
    -- about the point at `centre`
    let delta = pixelsToCoord z ((width // 2), (height // 2))
        minCoord = translate centre (reflect delta)
        maxCoord = translate centre delta
    in ((tileCovering minCoord z),
        (translate (tileCovering maxCoord z) (TileNumber 1 1)))

-- MODEL

type DragTarget = Map | Graph | StartMark | EndMark | NoTarget

type Drag
    = None
    | Dragging DragTarget (Int, Int)  (Int, Int)


dragTo : Drag ->  (Int, Int) -> Drag
dragTo d dest =
    case d of
        None -> None
        Dragging target from _ -> Dragging target from dest

dragDelta target d =
    case d of
        Dragging target_ (fx,fy) (tx,ty) ->
            if target == target_
            then (fx-tx, fy-ty)
            else (0, 0)
        _ -> (0, 0)

subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty)


type TrackState = Empty | Loading | Failure String | Present (List Point)
type alias Model =
    { centre: Coord
    , zoom: FineZoomLevel
    , drag: Drag
    , startTime : Float
    , duration : Float
    , markedTime : (Float, Float)
    , track: TrackState }

init : () -> Url -> Nav.Key -> (Model, Cmd Msg)
init _ url navKey =
    let (start, duration) =
            case Url.Parser.parse routeParser url of
                Just (Timeline (Just s) (Just d)) -> (toFloat s, toFloat d)
                _ -> (10,10)
    in
        ((Model
              (toCoord (Pos 0 0 Nothing))
              (FineZoomLevel (1*8)) None 0 0 (0,0) Loading),
             (fetchTrack start duration))

-- SUBSCRIPTIONS

subscriptions : Model -> Sub Msg
subscriptions model = Sub.none


fetchTrack start duration = Http.get
        { url = ("http://localhost:3000/points?start=" ++
                     String.fromInt (floor start) ++
                     "&duration=" ++
                     String.fromInt (ceiling duration))
        , expect = Http.expectJson Loaded (D.list Point.decoder)
        }



-- UPDATE

type Msg
  = MapScale Int
  | DragStart DragTarget (Int, Int)
  | Drag (Int, Int)
  | DragFinish (Int, Int)
  | TimeScale (Float)
  | Loaded (Result Http.Error (List Point))
  | NewUrlRequest
  | UrlChanged
  | Dribble String


update : Msg -> Model -> (Model, Cmd Msg)

update msg model = (updateModel msg model, Cmd.none)

secondsFromPixels model seconds =
    (toFloat seconds) * model.duration / portalWidth

handleDragFinish model target (x, y) =
    case target of
        Map ->
            { model |
                  centre = translatePixels model.centre (toZoom model.zoom) (x, y)
            }
        Graph ->
            { model |
                  startTime =
                  model.startTime + secondsFromPixels model x
            }
        StartMark ->
            { model |
                  markedTime =
                  let deltat = secondsFromPixels model x
                      (s, d) = model.markedTime
                  in (s - deltat, d + deltat)
            }
        EndMark ->
            { model |
                  markedTime =
                  let deltat = secondsFromPixels model x
                      (s, d) = model.markedTime
                  in (s, d - deltat)
            }
        NoTarget -> model


updateModel msg model =
    case msg of
        MapScale y ->
            { model | zoom = incZoom model.zoom y }

        DragStart target (x,y) ->
            { model | drag = Dragging target (x,y) (x,y) }

        Drag (x,y) ->
            { model | drag = dragTo model.drag (x,y) }

        DragFinish (x,y) ->
            case model.drag of
                Dragging target start end ->
                    handleDragFinish { model | drag = None } target (subtractTuple start end)

                _ -> model
        TimeScale factor ->
            { model |
                  startTime = model.startTime + factor / 2
            ,     duration = model.duration - factor
            }

        Loaded result ->
            case result of
                Ok trk ->
                    let start = Maybe.withDefault 0 (Point.startTime trk)
                        duration = Point.duration trk
                    in
                    { model
                        | track = Present trk
                        , centre = toCoord (Point.centre trk)
                        , zoom = FineZoomLevel (13  * 8)
                        , startTime = start
                        , duration = duration
                        , markedTime = (start + 300, duration - 900)
                    }
                Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") }
                Err e -> { model | track = Debug.log "unknown error" (Failure "e") }
        NewUrlRequest -> model
        UrlChanged ->  model
        Dribble message ->
            let _ = Debug.log "dribble" message
            in model


-- VIEW

formatTime epoch =
    let utc = Time.utc
        time = Time.millisToPosix <| floor(epoch * 1000)
        zeroed i = String.padLeft 2 '0' (String.fromInt i)
    in String.fromInt (Time.toHour utc time)
        ++ ":" ++
        zeroed (Time.toMinute utc time)
        ++ ":" ++
        zeroed (Time.toSecond utc time)

timeTick duration =
    let width = duration / 6
        candidates =
            [ 1
            , 3
            , 5
            , 10
            , 15
            , 30
            , 60
            , 60 * 3
            , 60 * 5
            , 60 * 10
            , 60 * 15
            , 60 * 30
            , 60 * 60
            ]
    in case List.Extra.find (\ candidate -> width <= candidate) candidates of
           Just n -> n
           Nothing -> width

tileUrl : TileNumber -> ZoomLevel -> String
tileUrl {x,y} z =
    String.concat ["https://a.tile.openstreetmap.org",
                       "/", String.fromInt z,
                       "/", String.fromInt x,
                       "/", String.fromInt y,
                       ".png" ]

tileImg zoom tilenumber = img [ width 256,
                                height 256,
                                src (tileUrl tilenumber zoom) ] []

type alias Colour = String

measureView : String -> Colour -> (Point -> Maybe Float) -> List Point -> Svg Msg
measureView title colour fn points =
    let graphHeight = 180
        startTime = Maybe.withDefault 0 (Point.startTime points)
        coords p = case (fn p) of
                       Just c ->
                           (String.fromFloat (p.time - startTime)) ++ "," ++
                           (String.fromFloat c) ++ ", "
                       Nothing -> ""
        maxY = List.foldr max 0 (List.filterMap fn points)
        minY = List.foldr min maxY (List.filterMap fn points)
        (minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY
        rangeYaxis = maxYaxis - minYaxis
        maxX = Point.duration points
        string = String.concat (List.map coords points)
        ttick = timeTick maxX
        firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
        ybar n = line
                 [ fill "none"
                 , style "vector-effect" "non-scaling-stroke"
                 , strokeWidth "1"
                 , stroke "#aaa"
                 , x1 "0"
                 , y1 (String.fromFloat (minYaxis + n * tickY))
                 , x2 (String.fromFloat (0.95 * maxX))
                 , y2 (String.fromFloat (minYaxis + n * tickY))
                 ] []
        xtick n =
            let t = firstTimeTick + n * timeTick maxX
                xpix = t * portalWidth/maxX
                label = formatTime (t + startTime)
            in
                g []
                    [ line
                          [ fill "none"
                          , style "vector-effect" "non-scaling-stroke"
                          , strokeWidth "1"
                          , stroke "#aaa"
                          , x1 (String.fromFloat xpix)
                          , y1 "0"
                          , x2 (String.fromFloat xpix)
                          , y2 "180"
                          ] []
                    ]

        ylabel n = Svg.text_
          [ x "99%", y (String.fromFloat (graphHeight - graphHeight * n * (tickY/rangeYaxis)))
          , style "text-anchor" "end"
          , style "fill" "#222244"
          ] [ Svg.text (String.fromFloat (minYaxis + n * tickY)) ]

    in
        svg
        [ width portalWidth
        , height graphHeight
        , preserveAspectRatio "none"
        ]
        [ rect
              [ x "0"
              , width portalWidth
              , height graphHeight
              , fill "#eef"
              , stroke "none"
              ] []
        , g
          [ stroke colour
          , strokeWidth "2"
          , transform ( "scale(" ++ (String.fromFloat (portalWidth / maxX)) ++
                            ", " ++ (String.fromFloat (graphHeight / rangeYaxis)) ++")" ++
                            "translate(0, " ++ (String.fromFloat maxYaxis) ++") scale(1, -1)")
          ]
          [ ybar 0
          , ybar 1
          , ybar 2
          , ybar 3
          , polyline
               [ fill "none"
               , style "vector-effect" "non-scaling-stroke"
               , S.points string
               ] []
          ]
        , Svg.text_
          [ x "99%", y "12%"
          , style "fill" "#222244"
          , style "text-anchor" "end"
          , style "font-weight" "bold"
          , style "text-shadow" "2px 2px 1px #dddddd"
          ] [ Svg.text title
            ]
        , ylabel 0
        , ylabel 1
        , ylabel 2
        , ylabel 3
        , xtick 0
        , xtick 1
        , xtick 2
        , xtick 3
        , xtick 4
        , xtick 5
        ]

type alias TargetedPointerEvent =
    { pointerEvent : Pointer.Event
    , targetId : String
    }

targetedEventDecoder =
    D.map2 TargetedPointerEvent
        Pointer.eventDecoder
        (D.at ["target", "id"] D.string)

targetFor : String ->  DragTarget
targetFor s =
    case s of
        "left-marker" -> StartMark
        "right-marker" -> EndMark
        _ -> NoTarget

onDownWithTarget tag =
    let
        decoder =
            targetedEventDecoder
                |> D.map tag
                |> D.map options

        options message =
            { message = message
            , stopPropagation = True
            , preventDefault = True
            }
        in
        Html.Events.custom "pointerdown" decoder


timeAxis model points =
    let graphHeight = 30
        startTime = Maybe.withDefault 0 (Point.startTime points)
        maxX = Point.duration points
        ttick = timeTick maxX
        firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
        xtick n =
            let t = firstTimeTick + (toFloat n) * timeTick maxX
                xpix = t * portalWidth/maxX
                label = formatTime (t + startTime)
            in
                g []
                    [ line
                          [ fill "none"
                          , style "vector-effect" "non-scaling-stroke"
                          , strokeWidth "1"
                          , stroke "#333"
                          , x1 (String.fromFloat xpix)
                          , y1 "0"
                          , x2 (String.fromFloat xpix)
                          , y2 "10"
                          ] []
                    , Svg.text_ [ x (String.fromFloat xpix)
                                , style "text-anchor" "middle"
                                , style "vertical-align" "bottom"
                                , y "25" ]
                        [ Svg.text label ]
                    ]
        xticks = List.map xtick <| List.range 0 6
        bg = rect
             [ x "0"
             , width portalWidth
             , height graphHeight
             , fill "#eef"
             , stroke "none"
             ] []
        markStart x =
            let x1 = String.fromInt x
            in Svg.path
                [ S.d ("M " ++ x1 ++ " 40 " ++
                         "v -50 h 10 v 10 h -10 v -10")
                , fill "#7c7"
                , stroke "#4e4"
                , H.id "left-marker"
                , strokeWidth "3"
                ] []
        markEnd x =
            let x1 = String.fromInt x
            in Svg.path
                [ S.d ("M " ++ x1 ++ " 40 " ++
                         "v -50 h -10 v 10 h 10 v -10")
                , fill "#c77"
                , stroke "#e44"
                , H.id "right-marker"
                , strokeWidth "3"
                ] []
        markStartPix =
            case model.markedTime of
                (s, d) ->
                    floor ((s  - startTime) * portalWidth/maxX) - (Tuple.first (dragDelta StartMark model.drag))
        markEndPix =
            case model.markedTime of
                (s, d) ->
                    ceiling ((s - startTime + d) * portalWidth/maxX)  -  (Tuple.first (dragDelta EndMark model.drag))
        epos e = Tuple.mapBoth floor floor e.pointer.clientPos
    in
        svg
        [ width portalWidth
        , height (graphHeight + 20)
        , onDownWithTarget (\e -> DragStart (targetFor e.targetId) (epos e.pointerEvent))
        , viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
                       "  " ++ (String.fromInt (graphHeight + 10)))
        ]
        (bg::(markStart markStartPix)::(markEnd markEndPix)::xticks)


cadenceView : List Point -> Svg Msg
cadenceView =
    measureView "cadence" "#44ee44" (.cadence >> Maybe.map toFloat)

powerView = measureView "power" "#994444" (.power >> Maybe.map toFloat)

eleView = measureView "elevation" "#4444ee" (.pos >> .ele)


trackView : Int -> Int -> ZoomLevel -> List Point -> Svg Msg
trackView leftedge topedge zoom points =
    let plot p =
            let (x, y) = pixelFromCoord (toCoord p.pos) zoom
                x_ = x - leftedge
                y_ = y - topedge
            in (String.fromInt x_) ++ ", " ++
                (String.fromInt y_) ++ ", "
        line = String.concat (List.map plot points)
    in
    svg
    [ H.style "width" "100%"
    , H.style "height" "100%"
    , H.style "position" "absolute"
    ]
    [ g
      [ fill "none"
      , stroke "blue"
      , strokeWidth "7"
      , strokeOpacity "0.5"]
      [
       polyline
       [ fill "none"
       , S.points  line
       ] []
      ]
    ]


px x = String.fromInt x ++ "px"

tiles xs ys zoom =
    List.map
        (\ y -> div []
             (List.map (\ x -> tileImg zoom (TileNumber x y)) xs))
        ys

ifTrack : Model -> (List Point ->  Html msg) ->  Html msg
ifTrack model content =
    case model.track of
        Present t ->
            let (dt, _) = dragDelta Graph model.drag
                dpix = toFloat dt * model.duration / portalWidth
                start = model.startTime +  dpix
                points = Point.subseq t start model.duration |>
                         Point.downsample 300
            in  content points
        Failure f -> Debug.log f (div [] [ Html.text "failure", Html.text f])
        Loading -> div [] [Html.text "loading"]
        Empty -> div [] [Html.text "no points"]


canvas centre zoom width height model =
    let (mintile, maxtile) = boundingTiles centre zoom width height
        -- offset is pixel difference between centre (which *should*
        -- be the middle of the image) and actual middle of the canvas
        (pixelCentreX,pixelCentreY) = pixelFromCoord centre zoom
        leftedge = mintile.x * 256
        topedge = mintile.y * 256
        offsetX = pixelCentreX - (width // 2) - leftedge
        offsetY = pixelCentreY - (height // 2) - topedge
        pixWidth = (1 + maxtile.x - mintile.x) * 256
        pixHeight = (1 + maxtile.y - mintile.y) * 256
        xs = List.range mintile.x maxtile.x
        ys = List.range mintile.y maxtile.y
        epos e = Tuple.mapBoth floor floor e.pointer.clientPos
        tv = ifTrack model (trackView leftedge topedge zoom)
    in  div [style "position" "absolute"
            ,style "width" (px pixWidth)
            ,style "height" (px pixHeight)
            ,style "left" (px -offsetX)
            ,style "top" (px -offsetY)
            ,style "lineHeight" (px 0)
            ,Pointer.onUp (\e -> DragFinish (epos e))
            ,Pointer.onMove (\e -> Drag (epos e))
            ,Pointer.onDown (\e -> DragStart Map (epos e)) ]
        (tv :: tiles xs ys zoom)


portalWidth = 600
portalHeight = 600

withSwallowing m =
    { message = m
    , stopPropagation = True
    , preventDefault = True
    }

-- FIXME should do something useful with deltaMode as well as deltaY
mapWheelDecoder =
    let sgn x = floor((abs x)/x)
    in D.map (withSwallowing << MapScale << sgn) (D.field "deltaY" D.float)

timeWheelDecoder =
    D.map (withSwallowing << TimeScale) (D.field "deltaY" D.float)

viewDiv : Model -> Html Msg
viewDiv model =
    let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta Map model.drag))
        canvasV = canvas coord (toZoom model.zoom) portalWidth portalHeight model
        epos e = Tuple.mapBoth floor floor e.pointer.clientPos
    in div [ style "display" "flex"
           , style "column-gap" "15px"
           ]
        [ div [ style "display" "flex"
              , Html.Events.custom "wheel" mapWheelDecoder
              , style "flex-direction" "column"]
              [ div [ style "width" (px portalWidth)
                    , style "height" (px portalHeight)
                    , style "display" "inline-block"
                    , style "position" "relative"
                    , style "overflow" "hidden"]
                    [canvasV]
              , text ("Zoom level " ++ (String.fromInt (toZoom model.zoom)))
              , span []
                  [ button [ onClick (MapScale -zoomStep) ] [ text "-" ]
                  , button [ onClick (MapScale zoomStep) ] [ text "+" ]
                  ]
              ]
        , div [ style "display" "flex"
              , Html.Events.custom "wheel" timeWheelDecoder
              , Pointer.onUp (\e -> DragFinish (epos e))
              , Pointer.onMove (\e -> Drag (epos e))
              , Pointer.onDown (\e -> DragStart Graph (epos e))
              , style "flex-direction" "column"
              , style "row-gap" "10px"
              ]
            [ div [] [ ifTrack model cadenceView ]
            , div [] [ ifTrack model powerView ]
            , div [] [ ifTrack model eleView ]
            , div [] [ ifTrack model (timeAxis model) ]
            ]
        ]

view : Model -> Browser.Document Msg
view model =
    Browser.Document  "Souplesse" [  (viewDiv model) ]