commit ddd461dc8d19229e204852360b270bc4aa7f3159
parent dfe0a7dbd57ec222f3263c6a129c2695c3fea0b3
Author: Daniel Barlow <dan@telent.net>
Date: Wed, 27 Nov 2024 00:14:07 +0000
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
Diffstat:
2 files changed, 53 insertions(+), 79 deletions(-)
diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm
@@ -54,20 +54,6 @@ main =
-- MODEL
-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)
-
subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty)
@@ -80,7 +66,7 @@ init _ url navKey =
in
((Model
(toCoord (Pos 0 0 Nothing))
- (ZoomLevel 0) None 0 0 (0,0) Loading),
+ (ZoomLevel 0) Nothing 0 0 (0,0) Loading),
(fetchTrack start duration))
-- SUBSCRIPTIONS
@@ -103,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)
@@ -120,31 +106,29 @@ update msg model = (updateModel msg model, Cmd.none)
secondsFromPixels model seconds =
(toFloat seconds) * model.duration / portalWidth
-handleDragFinish model target (x, y) =
- case target of
- Map ->
- { model |
- centre = translatePixels model.centre model.zoom (x, y)
- }
- Graph ->
- { model |
- startTime =
- model.startTime + secondsFromPixels model x
- }
- StartMark ->
- { model |
- markedTime =
- let deltat = secondsFromPixels model x
- (s, d) = model.markedTime
- in (s - deltat, d + deltat)
- }
- EndMark ->
- { model |
- markedTime =
- let deltat = secondsFromPixels model x
- (s, d) = model.markedTime
- in (s, d - deltat)
- }
+
+
+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 =
@@ -152,18 +136,15 @@ updateModel msg model =
MapScale y ->
{ model | zoom = incZoom model.zoom y }
- DragStart target (x,y) ->
- { model | drag = Dragging target (x,y) (x,y) }
+ DragStart state ->
+ { 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
- Dragging target start end ->
- handleDragFinish { model | drag = None } target (subtractTuple start end)
-
- _ -> model
+ let m = dragUpdate model (x, y)
+ in { m | drag = Nothing }
TimeScale factor ->
let startTime = model.startTime + factor / 2
@@ -346,13 +327,6 @@ targetedEventDecoder =
Pointer.eventDecoder
(D.at ["target", "id"] D.string)
-targetFor : String -> Maybe DragTarget
-targetFor s =
- case s of
- "left-marker" -> Just StartMark
- "right-marker" -> Just EndMark
- _ -> Nothing
-
onDownWithTarget tag =
let
decoder =
@@ -368,6 +342,15 @@ 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 =
let graphHeight = 30
@@ -428,21 +411,16 @@ timeAxis model points =
markStartPix =
case model.markedTime of
(s, d) ->
- floor ((s - startTime) * portalWidth/maxX) - (Tuple.first (dragDelta StartMark model.drag))
+ floor ((s - startTime) * portalWidth/maxX)
markEndPix =
case model.markedTime of
(s, d) ->
- ceiling ((s - startTime + d) * portalWidth/maxX) - (Tuple.first (dragDelta EndMark model.drag))
- epos e = Tuple.mapBoth floor floor e.pointer.clientPos
+ ceiling ((s - startTime + d) * portalWidth/maxX)
in
svg
[ width portalWidth
, height (graphHeight + 20)
- , onDownWithTarget (\e ->
- case targetFor e.targetId of
- Just tgt -> DragStart tgt (epos e.pointerEvent)
- Nothing -> Dribble "drag with unknown target"
- )
+ , onDownWithTarget (handleDragMark model)
, viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
" " ++ (String.fromInt (graphHeight + 10)))
]
@@ -492,9 +470,7 @@ ifTrack : Model -> (List Point -> Html msg) -> Html msg
ifTrack model content =
case model.track of
Present t ->
- let (dt, _) = dragDelta Graph model.drag
- dpix = toFloat dt * model.duration / portalWidth
- start = model.startTime + dpix
+ let start = model.startTime
points = Point.subseq t start model.duration |>
Point.downsample 300
in content points
@@ -519,7 +495,7 @@ canvas centre zoom width height model =
,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 tm)
@@ -542,8 +518,7 @@ timeWheelDecoder =
viewDiv : Model -> Html Msg
viewDiv model =
- let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta Map model.drag))
- canvasV = canvas coord model.zoom portalWidth portalHeight model
+ let canvasV = canvas model.centre model.zoom portalWidth portalHeight model
epos e = Tuple.mapBoth floor floor e.pointer.clientPos
in div [ style "display" "flex"
, style "column-gap" "15px"
@@ -566,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"
]
diff --git a/frontend/src/Model.elm b/frontend/src/Model.elm
@@ -2,24 +2,23 @@ module Model exposing
(
Model
, TrackState(..)
- , Drag(..)
- , DragTarget(..)
+ , DragState(..)
)
import TileMap exposing (ZoomLevel, Coord)
import Point exposing (Point)
-type DragTarget = Map | Graph | StartMark | EndMark
-
-type Drag
- = None
- | Dragging DragTarget (Int, Int) (Int, Int)
+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: Drag
+ , drag: Maybe DragState
, startTime : Float
, duration : Float
, markedTime : (Float, Float)
