commit 1e2c54b0e1275b534ca37d1986fed546ff489d4d
parent 6e4c1b735145f7ce625e9439e6170d833acafdfb
Author: Daniel Barlow <dan@telent.net>
Date: Sun, 27 Oct 2024 17:53:59 +0000
WIP before change of direction
Diffstat:
6 files changed, 296 insertions(+), 57 deletions(-)
diff --git a/elm.json b/elm.json
@@ -1,7 +1,7 @@
{
"type": "application",
"source-directories": [
- "src"
+ "frontend/src"
],
"elm-version": "0.19.1",
"dependencies": {
@@ -9,13 +9,17 @@
"elm/browser": "1.0.2",
"elm/core": "1.0.5",
"elm/html": "1.0.0",
+ "elm/http": "2.0.0",
+ "elm/svg": "1.0.1",
"elm/time": "1.0.0",
"elm-explorations/test": "2.2.0",
+ "mpizenberg/elm-pointer-events": "5.0.0",
"rtfeldman/elm-iso8601-date-strings": "1.1.4",
"ymtszw/elm-xml-decode": "3.2.2"
},
"indirect": {
"elm/bytes": "1.0.8",
+ "elm/file": "1.0.5",
"elm/json": "1.1.3",
"elm/parser": "1.1.0",
"elm/random": "1.0.0",
diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm
@@ -0,0 +1,291 @@
+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 Http
+import Svg exposing (Svg, svg, rect, circle, g)
+import Svg.Attributes as S exposing
+ ( viewBox
+ , x, y
+ , r, rx, ry
+ , cx, cy
+ , fill
+ , stroke, strokeWidth, strokeOpacity)
+
+import Track exposing (Track)
+-- import ExampleTrack
+
+
+-- 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 Track
+type alias Model =
+ { centre: Coord
+ , zoom: Zoom
+ , drag: Drag
+ , track: TrackState }
+
+init : () -> (Model, Cmd Msg)
+init _ = ((Model (toCoord 51.60 -0.01) 16 None Empty), fetchTrack)
+
+-- SUBSCRIPTIONS
+
+subscriptions : Model -> Sub Msg
+subscriptions model = Sub.none
+
+
+fetchTrack = Http.get
+ { url = "/track.gpx.xml"
+ , expect = Http.expectString Loaded
+ }
+
+
+-- UPDATE
+
+type Msg
+ = ZoomIn
+ | ZoomOut
+ | Scroll Int Int
+ | PointerDown (Int, Int)
+ | PointerMove (Int, Int)
+ | PointerUp (Int, Int)
+ | Loaded (Result Http.Error String)
+
+
+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 = case Track.parse trk of
+ Ok track -> Present track
+ Err _ -> Failure "parse failed"
+ }
+ Err e -> { model | track = 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 : Track -> Svg Msg
+
+
+trackView track =
+ svg
+ [H.style "width" "100%"
+ ,H.style "height" "100%"
+ ,H.style "position" "absolute"
+ ]
+ [ g
+ [fill "none"
+ ,stroke "blue"
+ ,strokeWidth "7"
+ ,strokeOpacity "0.5"]
+ [ rect
+ [ x "10"
+ , y "10"
+ , S.width "100"
+ , S.height "100"
+ , rx "15"
+ , ry "15"
+ ]
+ []
+ , circle
+ [ cx "50"
+ , cy "50"
+ , r "50"
+ ]
+ []
+ ]]
+
+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
+ Failure 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)) ]
+ ]
diff --git a/src/Track.elm b/frontend/src/Track.elm
diff --git a/tests/Fixtures.elm b/frontend/tests/Fixtures.elm
diff --git a/tests/TrackTest.elm b/frontend/tests/TrackTest.elm
diff --git a/src/Main.elm b/src/Main.elm
@@ -1,56 +0,0 @@
-module Main exposing (..)
-
-import Browser
-import Html exposing (Html, button, div, text)
-import Html.Events exposing (onClick)
-import Track exposing (Track)
-
--- MAIN
-
-
-main =
- Browser.sandbox { init = init, update = update, view = view }
-
-
-
--- MODEL
-
-
-type alias Model = Track
-
-
-init : Model
-init =
- Track.read "hello"
-
-
-
--- UPDATE
-
-
-type Msg
- = Increment
- | Decrement
-
-
-update : Msg -> Model -> Model
-update msg model =
- case msg of
- Increment ->
- model
-
- Decrement ->
- model
-
-
-
--- VIEW
-
-
-view : Model -> Html Msg
-view model =
- div []
- [ button [ onClick Decrement ] [ text "-" ]
- , div [] [ text (String.fromInt (List.length model)) ]
- , button [ onClick Increment ] [ text "+" ]
- ]
