rewrite drag handling

We do almost all the same things to update an in-progress drag
(scrolls, repaints, bounds checking etc) as for a finished drag, so
imo the model state (centre, startTime etc) during a drag should be
updated just the same as it is after the button is released

Makefile

@@ -3,6 +3,7 @@ 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/frontend.js: frontend/src/Main.elm frontend/src/Lib.elm frontend/src/Point.elm
+FRONTEND=Main.elm Lib.elm Point.elm Pos.elm TileMap.elm
+frontend/frontend.js: $(patsubst %,frontend/src/%,$(FRONTEND))
 	elm-test frontend/tests/
 	elm make --output=$@ $<

frontend/src/Main.elm

@@ -7,11 +7,13 @@ 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, Pos ,decoder)
+import Point exposing (Point, decoder)
+import Pos exposing (Pos)
 import Svg exposing (Svg, svg, rect, g, polyline, line)
 import Svg.Attributes as S exposing
     ( viewBox
@@ -22,6 +24,7 @@ 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)
@@ -47,110 +50,13 @@ 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
 
-type Drag
+subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty)
-    = 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) =
@@ -160,7 +66,7 @@ init _ url navKey =
     in
         ((Model
               (toCoord (Pos 0 0 Nothing))
-              (FineZoomLevel (1*8)) None 0 0 (0,0) Loading),
+              (ZoomLevel 0) Nothing 0 0 (0,0) Loading),
              (fetchTrack start duration))
 
 -- SUBSCRIPTIONS
@@ -183,7 +89,7 @@ fetchTrack start duration = Http.get
 
 type Msg
   = MapScale Int
-  | DragStart DragTarget (Int, Int)
+  | DragStart DragState
   | Drag (Int, Int)
   | DragFinish (Int, Int)
   | TimeScale (Float)
@@ -197,57 +103,60 @@ 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 target (x,y) ->
+        DragStart state ->
-            { model | drag = Dragging target (x,y) (x,y) }
+            { model | drag = Just state }
 
         Drag (x,y) ->
-            { model | drag = dragTo model.drag (x,y) }
+            dragUpdate model (x, y)
 
         DragFinish (x,y) ->
-            case model.drag of
+            let m = dragUpdate model (x, y)
-                Dragging Map start end ->
+            in { m | drag = Nothing }
-                    { 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 fudge = factor
+            let startTime = model.startTime + factor / 2
-                len = model.duration - fudge
+                duration = model.duration - factor
             in { model |
-                     startTime = model.startTime + fudge / 2
+                  startTime = startTime
-               ,     duration = len
+            ,     duration = duration
-               }
+            ,     markedTime =
+                  let (s, d) = model.markedTime
+                  in ( max s startTime
+                     , (min (s + d) (startTime + duration)) - s)
+            }
 
         Loaded result ->
             case result of
@@ -258,7 +167,7 @@ updateModel msg model =
                     { model
                         | track = Present trk
                         , centre = toCoord (Point.centre trk)
-                        , zoom = FineZoomLevel (13  * 8)
+                        , zoom = ZoomLevel (13  * 8)
                         , startTime = start
                         , duration = duration
                         , markedTime = (start + 300, duration - 900)
@@ -305,18 +214,6 @@ 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
@@ -380,7 +277,7 @@ measureView title colour fn points =
               [ x "0"
               , width portalWidth
               , height graphHeight
-              , fill "#eef"
+              , fill "#f8f8ff"
               , stroke "none"
               ] []
         , g
@@ -430,13 +327,6 @@ 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 =
@@ -452,6 +342,14 @@ 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 =
@@ -510,19 +408,19 @@ timeAxis model points =
                 , H.id "right-marker"
                 , strokeWidth "3"
                 ] []
-        markStartPix = case model.markedTime of
+        markStartPix =
-                           (s, d) ->
+            case model.markedTime of
-                               floor ((s - startTime) * portalWidth/maxX)
+                (s, d) ->
-        markEndPix = case model.markedTime of
+                    floor ((s  - startTime) * portalWidth/maxX)
-                           (s, d) ->
+        markEndPix =
-                               ceiling ((s - startTime + d) * portalWidth/maxX)
+            case model.markedTime of
-        epos e = Tuple.mapBoth floor floor e.pointer.clientPos
+                (s, d) ->
-
+                    ceiling ((s - startTime + d) * portalWidth/maxX)
     in
         svg
         [ width portalWidth
         , height (graphHeight + 20)
-        , onDownWithTarget (\e -> DragStart (targetFor e.targetId) (epos e.pointerEvent))
+        , onDownWithTarget (handleDragMark model)
         , viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
                        "  " ++ (String.fromInt (graphHeight + 10)))
         ]
@@ -537,7 +435,6 @@ 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 =
@@ -569,19 +466,11 @@ 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 (dt, _) = dragDelta Graph model.drag
+            let start = model.startTime
-                dpix = toFloat dt * model.duration / portalWidth
-                start = model.startTime +  dpix
                 points = Point.subseq t start model.duration |>
                          Point.downsample 300
             in  content points
@@ -589,32 +478,25 @@ 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 (mintile, maxtile) = boundingTiles centre zoom width height
+    let tm = TileMap centre zoom width height
-        -- offset is pixel difference between centre (which *should*
+        mapBounds = TileMap.bounds tm
-        -- be the middle of the image) and actual middle of the canvas
+        (pixelCentreX, pixelCentreY) = pixelFromCoord centre zoom
-        (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 leftedge topedge zoom)
+        tv = ifTrack model (trackView mapBounds.left mapBounds.top zoom)
     in  div [style "position" "absolute"
-            ,style "width" (px pixWidth)
+            ,style "width" (px mapBounds.width)
-            ,style "height" (px pixHeight)
+            ,style "height" (px mapBounds.height)
             ,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)) ]
+            ,Pointer.onDown (\e -> DragStart (DragMap (epos e) model.centre))]
-        (tv :: tiles xs ys zoom)
+        (tv :: tiles tm)
 
 
 portalWidth = 600
@@ -636,8 +518,7 @@ timeWheelDecoder =
 
 viewDiv : Model -> Html Msg
 viewDiv model =
-    let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta Map model.drag))
+    let canvasV = canvas model.centre model.zoom portalWidth portalHeight model
-        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"
@@ -651,7 +532,6 @@ 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 "+" ]
@@ -661,7 +541,7 @@ viewDiv model =
               , Html.Events.custom "wheel" timeWheelDecoder
               , Pointer.onUp (\e -> DragFinish (epos e))
               , Pointer.onMove (\e -> Drag (epos e))
-              , Pointer.onDown (\e -> DragStart Graph (epos e))
+              , Pointer.onDown (\e -> DragStart (DragGraph (epos e) model.startTime))
               , style "flex-direction" "column"
               , style "row-gap" "10px"
               ]

frontend/src/Model.elm

@@ -0,0 +1,25 @@
+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,12 +1,7 @@
-module Point exposing(Pos, Point, decoder, downsample, duration, subseq, startTime, centre)
+module Point exposing(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

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

frontend/src/TileMap.elm

@@ -0,0 +1,128 @@
+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,6 +1,7 @@
 module PointTest exposing (specs)
 
-import Point exposing (Point, Pos, downsample, subseq)
+import Point exposing (Point, downsample, subseq)
+import Pos exposing (Pos)
 import Test exposing (..)
 import Expect exposing (Expectation)