module Main exposing (view) import Browser 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) import Html.Events.Extra.Pointer as Pointer import Maybe exposing (Maybe) import Json.Decode as D import Http import Svg exposing (Svg, svg, rect, circle, g, polyline) import Svg.Attributes as S exposing ( viewBox , x, y , r, rx, ry , cx, cy , fill , points , stroke, strokeWidth, strokeOpacity) -- MAIN main = Browser.element { init = init , update = update , subscriptions = subscriptions , view = view } -- MATHS -- Coordinates in a Mercator projection type alias Coord = { x: Float, y: Float } -- zoom level type alias Zoom = Int type alias TileNumber = { x: Int, y: Int } type alias Lat = Float type alias Lng = Float -- project latling 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 -> Zoom -> (Int, Int) -> Coord translatePixels old z (x, y) = translate old (pixelsToCoord z (x, y)) tileCovering : Coord -> Zoom -> TileNumber tileCovering c z = TileNumber (truncate (toFloat (2 ^ z) * c.x)) (truncate (toFloat (2 ^ z) * c.y)) pixelFromCoord : Coord -> Zoom -> (Int, Int) pixelFromCoord c z = let {x,y} = tileCovering c (z + 8) in (x,y) boundingTiles : Coord -> Zoom -> 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: Zoom , drag: Drag , track: TrackState } init : () -> (Model, Cmd Msg) init _ = ((Model (toCoord 51.60 -0.01) 13 None Empty), fetchTrack) -- SUBSCRIPTIONS subscriptions : Model -> Sub Msg subscriptions model = Sub.none fetchTrack = Http.get { url = "http://localhost:3000/points?start=1729668899&duration=2842" , expect = Http.expectJson Loaded trackDecoder } type alias Pos = { lat : Float , lon : Float , ele : Maybe Float } type alias Point = { time : Float , pos : Pos } posDecoder : D.Decoder Pos posDecoder = D.map3 Pos (D.field "lat" D.float) (D.field "lon" D.float) (D.field "ele" (D.maybe D.float)) pointDecoder : D.Decoder Point pointDecoder = D.map2 Point (D.field "time" D.float) (D.field "pos" posDecoder) trackDecoder : D.Decoder (List Point) trackDecoder = D.list pointDecoder -- UPDATE type Msg = ZoomIn | ZoomOut | Scroll Int Int | PointerDown (Int, Int) | PointerMove (Int, Int) | PointerUp (Int, Int) | Loaded (Result Http.Error (List Point)) update : Msg -> Model -> (Model, Cmd Msg) update msg model = (newModel msg model, Cmd.none) newModel msg model = case msg of ZoomIn -> { model | zoom = model.zoom + 1 } ZoomOut -> { model | zoom = model.zoom - 1 } Scroll x y -> { model | centre = translatePixels model.centre 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 model.zoom (dragDelta model.drag) } 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") } -- VIEW tileUrl : TileNumber -> Zoom -> 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) ] [] trackView : List Point -> Int -> Int -> Zoom -> Svg Msg trackView points leftedge topedge zoom = 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 canvas centre zoom width height track = 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 = case track of Present t -> trackView t leftedge topedge zoom Failure f -> Debug.log f (div [] [ text "failure", text f]) Loading -> div [] [text "loading"] Empty -> div [] [text "no points"] 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 view : Model -> Html Msg view model = let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta model.drag)) canvasV = canvas coord model.zoom portalWidth portalHeight model.track in div [] [ (div [ style "width" (px portalWidth) , style "height" (px portalHeight) , style "display" "inline-block" , style "position" "relative" , style "overflow" "hidden"] [canvasV]) , div [] [ text (String.fromInt model.zoom ) ] , div [] [ case model.track of -- Present tk -> text (String.fromInt (List.length tk)) _ -> text "dgdfg" ] , button [ onClick ZoomOut ] [ text "-" ] , button [ onClick ZoomIn ] [ 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 [] [ text (Debug.toString (List.length model.track)) ] ]