module Main exposing (view) import Browser import Browser.Navigation as Nav import Html exposing (Html, button, div, span, text, img, pre) 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 Json.Decode as D import Http import Point exposing(Point, Pos ,decoder) import Svg exposing (Svg, svg, rect, circle, g, polyline, line) import Svg.Attributes as S exposing ( viewBox , preserveAspectRatio , transform , x, y , x1, y1 , x2, y2 , r, rx, ry , cx, cy , fill , points , stroke, strokeWidth, strokeOpacity) import Url.Parser exposing (Parser, (), (), int, map, oneOf, 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 = (\ ur -> NewUrlRequest) , onUrlChange = (\ u -> 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 } type alias Lat = Float type alias Lng = Float -- 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 : Lat -> Lng -> Coord toCoord lat lng = let lat_rad = lat * pi / 180 x = (lng + 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 Drag = None | Dragging (Int, Int) (Int, Int) dragTo : Drag -> (Int, Int) -> Drag dragTo d dest = case d of None -> None Dragging from to -> Dragging from dest dragDelta d = case d of None -> (0,0) Dragging (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 : Int , duration : Int , 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)) -> (s, d) _ -> (10,10) in ((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None start duration Empty), (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 start ++ "&duration=" ++ String.fromInt duration) , expect = Http.expectJson Loaded (D.list Point.decoder) } -- UPDATE type Msg = MapZoomIn | MapZoomOut | MapScale Float | Scroll Int Int | PointerDown (Int, Int) | PointerMove (Int, Int) | PointerUp (Int, Int) | TimeScale (Float) | Loaded (Result Http.Error (List Point)) | NewUrlRequest | UrlChanged update : Msg -> Model -> (Model, Cmd Msg) update msg model = (newModel msg model, Cmd.none) newModel msg model = case msg of MapZoomIn -> { model | zoom = incZoom model.zoom zoomStep } MapZoomOut -> { model | zoom = incZoom model.zoom -zoomStep } MapScale y -> let dir = floor(abs(y)/y) in { model | zoom = incZoom model.zoom dir } Scroll x y -> { model | centre = translatePixels model.centre (toZoom model.zoom) (x,y) } PointerDown (x,y) -> { model | drag = Dragging (x,y) (x,y) } PointerMove (x,y) -> { model | drag = dragTo model.drag (x,y) } PointerUp (x,y) -> { model | drag = None, centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) } TimeScale factor -> let fudge = factor len = model.duration - floor(fudge) in { model | startTime = model.startTime + floor(fudge / 2) , duration = len } Loaded result -> case result of Ok trk -> { model | track = Present trk } 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 -- VIEW 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 allPoints = let filteredPoints = Point.downsample 300 allPoints graphHeight = 180 startTime = case allPoints of (p::_) -> p.time _ -> 0 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 filteredPoints) minY = List.foldr min maxY (List.filterMap fn filteredPoints) (minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY rangeYaxis = maxYaxis - minYaxis maxX = Point.duration allPoints string = String.concat (List.map coords filteredPoints) 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)) ] [] 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 ] 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.lat p.pos.lon) 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 points = Point.subseq t (toFloat model.startTime) (toFloat model.duration) 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 -> PointerUp (epos e)) ,Pointer.onMove (\e -> PointerMove (epos e)) ,Pointer.onDown (\e -> PointerDown (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 = D.map (withSwallowing << MapScale) (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 model.drag)) canvasV = canvas coord (toZoom model.zoom) portalWidth portalHeight model 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 MapZoomOut ] [ text "-" ] , button [ onClick MapZoomIn ] [ text "+" ] , button [ onClick (Scroll 0 -10) ] [ text "^" ] , button [ onClick (Scroll 0 10) ] [ text "V" ] , button [ onClick (Scroll -10 0) ] [ text "<" ] , button [ onClick (Scroll 10 0) ] [ text ">" ] ] ] , div [ style "display" "flex" , Html.Events.custom "wheel" timeWheelDecoder , style "flex-direction" "column" , style "row-gap" "10px" ] [ div [] [ ifTrack model cadenceView ] , div [] [ ifTrack model powerView ] , div [] [ ifTrack model eleView ] ] ] view : Model -> Browser.Document Msg view model = Browser.Document "Souplesse elm" [ (viewDiv model) ]