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) ]