Makefile

@@ -3,7 +3,6 @@ default: frontend/frontend.js dist-newstyle/build/x86_64-linux/ghc-9.6.5/souples
 dist-newstyle/build/x86_64-linux/ghc-9.6.5/souplesse-0.1.0.0/x/souplesse/build/souplesse/souplesse: app/*.hs lib/*.hs
 	cabal build
 
-FRONTEND=Main.elm Lib.elm Point.elm Pos.elm TileMap.elm
+frontend/frontend.js: frontend/src/Main.elm frontend/src/Lib.elm frontend/src/Point.elm
-frontend/frontend.js: $(patsubst %,frontend/src/%,$(FRONTEND))
 	elm-test frontend/tests/
 	elm make --output=$@ $<

frontend/src/Main.elm

@@ -7,13 +7,11 @@ 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 Model exposing (..)
 import Lib exposing(..)
 import List.Extra exposing(find)
 import Json.Decode as D
 import Http
-import Point exposing (Point, decoder)
+import Point exposing(Point, Pos ,decoder)
-import Pos exposing (Pos)
 import Svg exposing (Svg, svg, rect, g, polyline, line)
 import Svg.Attributes as S exposing
     ( viewBox
@@ -24,7 +22,6 @@ import Svg.Attributes as S exposing
     , fill
     , stroke, strokeWidth, strokeOpacity)
 import Time
-import TileMap exposing (..)
 import Url.Parser exposing (Parser, (<?>), int, map, s, string)
 import Url.Parser.Query as Query
 import Url exposing (Url)
@@ -50,13 +47,110 @@ main =
 
 -- 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
 
-subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty)
+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)
+
+subTuple (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) =
@@ -66,7 +160,7 @@ init _ url navKey =
     in
         ((Model
               (toCoord (Pos 0 0 Nothing))
-              (ZoomLevel 0) Nothing 0 0 (0,0) Loading),
+              (FineZoomLevel (1*8)) None 0 0 (0,0) Loading),
              (fetchTrack start duration))
 
 -- SUBSCRIPTIONS
@@ -89,7 +183,7 @@ fetchTrack start duration = Http.get
 
 type Msg
   = MapScale Int
-  | DragStart DragState
+  | DragStart DragTarget (Int, Int)
   | Drag (Int, Int)
   | DragFinish (Int, Int)
   | TimeScale (Float)
@@ -103,59 +197,56 @@ update : Msg -> Model -> (Model, Cmd Msg)
 
 update msg model = (updateModel msg model, Cmd.none)
 
-secondsFromPixels model seconds =
-    (toFloat seconds) * model.duration / portalWidth
-
-
-
-dragUpdate : Model -> (Int, Int) -> Model
-dragUpdate model (newx, newy) =
-  case model.drag of
-      Nothing -> model
-      Just (DragMap fromxy fromcoord) ->
-          let t = subtractTuple fromxy (newx, newy)
-          in { model | centre = translate fromcoord (pixelsToCoord model.zoom t) }
-      Just (DragGraph (fromx,_) fromtime) ->
-          let time = secondsFromPixels model (fromx - newx)
-          in { model | startTime = fromtime + time }
-      Just (DragLeftMark (fromx,_) (fromtime, fromduration)) ->
-          let time = secondsFromPixels model (fromx - newx)
-          in { model |
-                   markedTime = ((fromtime - time),
-                                     (max (fromduration + time) 0))
-             }
-      Just (DragRightMark (fromx,_) fromduration) ->
-          let time = secondsFromPixels model (fromx - newx)
-          in { model | markedTime = (Tuple.first model.markedTime,
-                                         (max (fromduration - time) 0)) }
-
-
-
 updateModel msg model =
     case msg of
         MapScale y ->
             { model | zoom = incZoom model.zoom y }
 
-        DragStart state ->
+        DragStart target (x,y) ->
-            { model | drag = Just state }
+            { model | drag = Dragging target (x,y) (x,y) }
 
         Drag (x,y) ->
-            dragUpdate model (x, y)
+            { model | drag = dragTo model.drag (x,y) }
 
         DragFinish (x,y) ->
-            let m = dragUpdate model (x, y)
+            case model.drag of
-            in { m | drag = Nothing }
+                Dragging Map start end ->
+                    { model |
+                          drag = None,
+                          centre = translatePixels model.centre (toZoom model.zoom) (subTuple start end) }
+                Dragging Graph start end ->
+                    { model |
+                          drag = None,
+                          startTime =
+                          let (delta, _) = subTuple start end
+                          in model.startTime + toFloat delta * model.duration / portalWidth
+                    }
+                Dragging StartMark start end ->
+                    { model |
+                          drag = None,
+                          markedTime =
+                          let delta = Tuple.first (subTuple start end)
+                              deltat = toFloat delta * model.duration / portalWidth
+                              (s, d) = model.markedTime
+                          in (s - deltat, d + deltat)
+                    }
+                Dragging EndMark start end ->
+                    { model |
+                          drag = None,
+                          markedTime =
+                          let delta = Tuple.first (subTuple start end)
+                              deltat = toFloat delta * model.duration / portalWidth
+                              (s, d) = model.markedTime
+                          in (s, d - deltat)
+                    }
 
+                _ -> model
         TimeScale factor ->
-            let startTime = model.startTime + factor / 2
+            let fudge = factor
-                duration = model.duration - factor
+                len = model.duration - fudge
             in { model |
-                  startTime = startTime
+                     startTime = model.startTime + fudge / 2
-            ,     duration = duration
+               ,     duration = len
-            ,     markedTime =
-                  let (s, d) = model.markedTime
-                  in ( max s startTime
-                     , (min (s + d) (startTime + duration)) - s)
                }
 
         Loaded result ->
@@ -167,7 +258,7 @@ updateModel msg model =
                     { model
                         | track = Present trk
                         , centre = toCoord (Point.centre trk)
-                        , zoom = ZoomLevel (13  * 8)
+                        , zoom = FineZoomLevel (13  * 8)
                         , startTime = start
                         , duration = duration
                         , markedTime = (start + 300, duration - 900)
@@ -214,6 +305,18 @@ timeTick duration =
            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
@@ -277,7 +380,7 @@ measureView title colour fn points =
               [ x "0"
               , width portalWidth
               , height graphHeight
-              , fill "#f8f8ff"
+              , fill "#eef"
               , stroke "none"
               ] []
         , g
@@ -327,6 +430,13 @@ targetedEventDecoder =
         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 =
@@ -342,14 +452,6 @@ onDownWithTarget tag =
         in
         Html.Events.custom "pointerdown" decoder
 
-handleDragMark model e =
-    let epos ev = Tuple.mapBoth floor floor ev.pointer.clientPos
-    in case e.targetId of
-        "left-marker" ->
-            DragStart (DragLeftMark (epos e.pointerEvent) model.markedTime)
-        "right-marker" ->
-            DragStart (DragRightMark (epos e.pointerEvent) (Tuple.second model.markedTime))
-        _ -> Dribble "drag with unknown target"
 
 
 timeAxis model points =
@@ -408,19 +510,19 @@ timeAxis model points =
                 , H.id "right-marker"
                 , strokeWidth "3"
                 ] []
-        markStartPix =
+        markStartPix = case model.markedTime of
-            case model.markedTime of
                            (s, d) ->
                                floor ((s - startTime) * portalWidth/maxX)
-        markEndPix =
+        markEndPix = case model.markedTime of
-            case model.markedTime of
                            (s, d) ->
                                ceiling ((s - startTime + d) * portalWidth/maxX)
+        epos e = Tuple.mapBoth floor floor e.pointer.clientPos
+
     in
         svg
         [ width portalWidth
         , height (graphHeight + 20)
-        , onDownWithTarget (handleDragMark model)
+        , onDownWithTarget (\e -> DragStart (targetFor e.targetId) (epos e.pointerEvent))
         , viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
                        "  " ++ (String.fromInt (graphHeight + 10)))
         ]
@@ -435,6 +537,7 @@ 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 =
@@ -466,11 +569,19 @@ trackView leftedge topedge zoom points =
 
 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 start = model.startTime
+            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
@@ -478,25 +589,32 @@ ifTrack model content =
         Loading -> div [] [Html.text "loading"]
         Empty -> div [] [Html.text "no points"]
 
-canvas : Coord -> ZoomLevel -> Int -> Int -> Model -> Html Msg
+
 canvas centre zoom width height model =
-    let tm = TileMap centre zoom width height
+    let (mintile, maxtile) = boundingTiles centre zoom width height
-        mapBounds = TileMap.bounds tm
+        -- 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
-        offsetX = pixelCentreX - (width // 2) - mapBounds.left
+        leftedge = mintile.x * 256
-        offsetY = pixelCentreY - (height // 2) - mapBounds.top
+        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 mapBounds.left mapBounds.top zoom)
+        tv = ifTrack model (trackView leftedge topedge zoom)
     in  div [style "position" "absolute"
-            ,style "width" (px mapBounds.width)
+            ,style "width" (px pixWidth)
-            ,style "height" (px mapBounds.height)
+            ,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 (DragMap (epos e) model.centre))]
+            ,Pointer.onDown (\e -> DragStart Map (epos e)) ]
-        (tv :: tiles tm)
+        (tv :: tiles xs ys zoom)
 
 
 portalWidth = 600
@@ -518,7 +636,8 @@ timeWheelDecoder =
 
 viewDiv : Model -> Html Msg
 viewDiv model =
-    let canvasV = canvas model.centre model.zoom portalWidth portalHeight 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"
@@ -532,6 +651,7 @@ viewDiv model =
                     , 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 "+" ]
@@ -541,7 +661,7 @@ viewDiv model =
               , Html.Events.custom "wheel" timeWheelDecoder
               , Pointer.onUp (\e -> DragFinish (epos e))
               , Pointer.onMove (\e -> Drag (epos e))
-              , Pointer.onDown (\e -> DragStart (DragGraph (epos e) model.startTime))
+              , Pointer.onDown (\e -> DragStart Graph (epos e))
               , style "flex-direction" "column"
               , style "row-gap" "10px"
               ]

frontend/src/Model.elm

@@ -1,25 +0,0 @@
-module Model exposing
-    (
-      Model
-    , TrackState(..)
-    , DragState(..)
-    )
-import TileMap exposing (ZoomLevel, Coord)
-import Point exposing (Point)
-
-type DragState =
-    DragMap (Int, Int) Coord
-  | DragGraph (Int, Int) Float
-  | DragLeftMark (Int, Int) (Float, Float)
-  | DragRightMark (Int, Int) Float
-
-type TrackState = Empty | Loading | Failure String | Present (List Point)
-
-type alias Model =
-    { centre: Coord
-    , zoom: ZoomLevel
-    , drag: Maybe DragState
-    , startTime : Float
-    , duration : Float
-    , markedTime : (Float, Float)
-    , track: TrackState }

frontend/src/Point.elm

@@ -1,7 +1,12 @@
-module Point exposing(Point, decoder, downsample, duration, subseq, startTime, centre)
+module Point exposing(Pos, Point, decoder, downsample, duration, subseq, startTime, centre)
 
 import Json.Decode as D
-import Pos exposing (Pos)
+
+type alias Pos =
+    { lat : Float
+    , lon : Float
+    , ele : Maybe Float
+    }
 
 
 type alias Point =

frontend/src/Pos.elm

@@ -1,7 +0,0 @@
-module Pos exposing (Pos)
-
-type alias Pos =
-    { lat : Float
-    , lon : Float
-    , ele : Maybe Float
-    }

frontend/src/TileMap.elm

@@ -1,128 +0,0 @@
-module TileMap exposing (tiles
-                        , ZoomLevel(..)
-                        , Coord
-                        , TileMap(..)
-                        , toCoord
-                        , toZoom
-                        , translate
-                        , translatePixels
-                        , incZoom
-                        , bounds
-                        , pixelsToCoord
-                        , pixelFromCoord
-                        , zoomStep)
-
-import Html exposing (img, div)
-import Html.Attributes as H exposing (src, style, width, height)
-
-import Pos exposing (Pos)
-
-type alias TileNumber = { x: Int, y: Int }
-
--- Coordinates in a Mercator projection
-type alias Coord = { x: Float, y: Float }
-
--- zoom level
-type alias TileZoomLevel = Int
-type ZoomLevel = ZoomLevel Int
-
-
-type TileMap = TileMap Coord ZoomLevel Int Int
-
-zoomStep = 8
-
-toZoom : ZoomLevel -> TileZoomLevel
-toZoom (ZoomLevel f) = f // zoomStep
-
-
-incZoom : ZoomLevel -> Int -> ZoomLevel
-incZoom (ZoomLevel z) delta =
-    ZoomLevel (clamp 0 (20 * zoomStep) (z + delta))
-
-
--- 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 scale = 8 + toZoom z_
-        x_float = toFloat x / toFloat ( 2 ^ scale)
-        y_float = toFloat y / toFloat ( 2 ^ scale)
-    in Coord x_float y_float
-
-reflect : Coord -> Coord
-reflect c = Coord -c.x -c.y
-
--- used for Coords and for TileNumbers
-translate base offset =
-    { 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 -> TileZoomLevel -> 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 z = toZoom z_
-        {x,y} = tileCovering c (z + 8)
-    in (x,y)
-
-boundingTiles : TileMap -> (TileNumber, TileNumber)
-boundingTiles (TileMap centre z1 width height) =
-    -- find the tiles needed to cover the area (`width` x `height`)
-    -- about the point at `centre`
-    let z = toZoom z1
-        delta = pixelsToCoord z1 ((width // 2), (height // 2))
-        minCoord = translate centre (reflect delta)
-        maxCoord = translate centre delta
-    in ((tileCovering minCoord z),
-        (translate (tileCovering maxCoord z) (TileNumber 1 1)))
-
-bounds : TileMap -> { left : Int, top : Int, width: Int, height: Int }
-bounds tmap =
-    let (mintile, maxtile) = boundingTiles tmap
-    in {
-        left = mintile.x * 256,
-        top = mintile.y * 256,
-        width = (1 + maxtile.x - mintile.x) * 256,
-        height = (1 + maxtile.y - mintile.y) * 256
-    }
-
-
-tileUrl : TileNumber -> TileZoomLevel -> 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) ] []
-
-tiles tmap =
-    let (TileMap centre zoom width height) = tmap
-        (mintile, maxtile) = boundingTiles tmap
-        xs = List.range mintile.x maxtile.x
-        ys = List.range mintile.y maxtile.y
-        zoom_ = toZoom zoom
-    in
-    List.map
-        (\ y -> div []
-             (List.map (\ x -> tileImg zoom_ (TileNumber x y)) xs))
-        ys

frontend/tests/PointTest.elm

@@ -1,7 +1,6 @@
 module PointTest exposing (specs)
 
-import Point exposing (Point, downsample, subseq)
+import Point exposing (Point, Pos, downsample, subseq)
-import Pos exposing (Pos)
 import Test exposing (..)
 import Expect exposing (Expectation)