dan/souplesse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rewrite drag handling

Browse Source 
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
This commit is contained in:
Daniel Barlow 2024-11-27 00:14:07 +00:00
parent dfe0a7dbd5
commit ddd461dc8d
2 changed files with 53 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

117
frontend/src/Main.elm
View File

@ -54,20 +54,6 @@ main =
-- MODEL -- 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) subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty)
@ -80,7 +66,7 @@ init _ url navKey =
in in
((Model ((Model
(toCoord (Pos 0 0 Nothing)) (toCoord (Pos 0 0 Nothing))
(ZoomLevel 0) None 0 0 (0,0) Loading), (ZoomLevel 0) Nothing 0 0 (0,0) Loading),
(fetchTrack start duration)) (fetchTrack start duration))
-- SUBSCRIPTIONS -- SUBSCRIPTIONS
@ -103,7 +89,7 @@ fetchTrack start duration = Http.get
type Msg type Msg
= MapScale Int = MapScale Int
| DragStart DragTarget (Int, Int) | DragStart DragState
| Drag (Int, Int) | Drag (Int, Int)
| DragFinish (Int, Int) | DragFinish (Int, Int)
| TimeScale (Float) | TimeScale (Float)
@ -120,31 +106,29 @@ update msg model = (updateModel msg model, Cmd.none)
secondsFromPixels model seconds = secondsFromPixels model seconds =
(toFloat seconds) * model.duration / portalWidth (toFloat seconds) * model.duration / portalWidth
handleDragFinish model target (x, y) =
case target of
Map -> dragUpdate : Model -> (Int, Int) -> Model
{ model | dragUpdate model (newx, newy) =
centre = translatePixels model.centre model.zoom (x, y) case model.drag of
} Nothing -> model
Graph -> Just (DragMap fromxy fromcoord) ->
{ model | let t = subtractTuple fromxy (newx, newy)
startTime = in { model | centre = translate fromcoord (pixelsToCoord model.zoom t) }
model.startTime + secondsFromPixels model x Just (DragGraph (fromx,_) fromtime) ->
} let time = secondsFromPixels model (fromx - newx)
StartMark -> in { model | startTime = fromtime + time }
{ model | Just (DragLeftMark (fromx,_) (fromtime, fromduration)) ->
markedTime = let time = secondsFromPixels model (fromx - newx)
let deltat = secondsFromPixels model x in { model |
(s, d) = model.markedTime markedTime = ((fromtime - time),
in (s - deltat, d + deltat) (max (fromduration + time) 0))
} }
EndMark -> Just (DragRightMark (fromx,_) fromduration) ->
{ model | let time = secondsFromPixels model (fromx - newx)
markedTime = in { model | markedTime = (Tuple.first model.markedTime,
let deltat = secondsFromPixels model x (max (fromduration - time) 0)) }
(s, d) = model.markedTime
in (s, d - deltat)
}
updateModel msg model = updateModel msg model =
@ -152,18 +136,15 @@ updateModel msg model =
MapScale y -> MapScale y ->
{ model | zoom = incZoom model.zoom 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) -> Drag (x,y) ->
{ model | drag = dragTo model.drag (x,y) } dragUpdate model (x, y)
DragFinish (x,y) -> DragFinish (x,y) ->
case model.drag of let m = dragUpdate model (x, y)
Dragging target start end -> in { m | drag = Nothing }
handleDragFinish { model | drag = None } target (subtractTuple start end)
_ -> model
TimeScale factor -> TimeScale factor ->
let startTime = model.startTime + factor / 2 let startTime = model.startTime + factor / 2
@ -346,13 +327,6 @@ targetedEventDecoder =
Pointer.eventDecoder Pointer.eventDecoder
(D.at ["target", "id"] D.string) (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 = onDownWithTarget tag =
let let
decoder = decoder =
@ -368,6 +342,15 @@ onDownWithTarget tag =
in in
Html.Events.custom "pointerdown" decoder 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 = timeAxis model points =
let graphHeight = 30 let graphHeight = 30
@ -428,21 +411,16 @@ timeAxis model points =
markStartPix = markStartPix =
case model.markedTime of case model.markedTime of
(s, d) -> (s, d) ->
floor ((s - startTime) * portalWidth/maxX) - (Tuple.first (dragDelta StartMark model.drag)) floor ((s - startTime) * portalWidth/maxX)
markEndPix = markEndPix =
case model.markedTime of case model.markedTime of
(s, d) -> (s, d) ->
ceiling ((s - startTime + d) * portalWidth/maxX) - (Tuple.first (dragDelta EndMark model.drag)) ceiling ((s - startTime + d) * portalWidth/maxX)
epos e = Tuple.mapBoth floor floor e.pointer.clientPos
in in
svg svg
[ width portalWidth [ width portalWidth
, height (graphHeight + 20) , height (graphHeight + 20)
, onDownWithTarget (\e -> , onDownWithTarget (handleDragMark model)
case targetFor e.targetId of
Just tgt -> DragStart tgt (epos e.pointerEvent)
Nothing -> Dribble "drag with unknown target"
)
, viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++ , viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
" " ++ (String.fromInt (graphHeight + 10))) " " ++ (String.fromInt (graphHeight + 10)))
] ]
@ -492,9 +470,7 @@ ifTrack : Model -> (List Point -> Html msg) -> Html msg
ifTrack model content = ifTrack model content =
case model.track of case model.track of
Present t -> 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 |> points = Point.subseq t start model.duration |>
Point.downsample 300 Point.downsample 300
in content points in content points
@ -519,7 +495,7 @@ canvas centre zoom width height model =
,style "lineHeight" (px 0) ,style "lineHeight" (px 0)
,Pointer.onUp (\e -> DragFinish (epos e)) ,Pointer.onUp (\e -> DragFinish (epos e))
,Pointer.onMove (\e -> Drag (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) (tv :: tiles tm)
@ -542,8 +518,7 @@ timeWheelDecoder =
viewDiv : Model -> Html Msg viewDiv : Model -> Html Msg
viewDiv model = viewDiv model =
let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta Map model.drag)) let canvasV = canvas model.centre model.zoom portalWidth portalHeight model
canvasV = canvas coord model.zoom portalWidth portalHeight model
epos e = Tuple.mapBoth floor floor e.pointer.clientPos epos e = Tuple.mapBoth floor floor e.pointer.clientPos
in div [ style "display" "flex" in div [ style "display" "flex"
, style "column-gap" "15px" , style "column-gap" "15px"
@ -566,7 +541,7 @@ viewDiv model =
, Html.Events.custom "wheel" timeWheelDecoder , Html.Events.custom "wheel" timeWheelDecoder
, Pointer.onUp (\e -> DragFinish (epos e)) , Pointer.onUp (\e -> DragFinish (epos e))
, Pointer.onMove (\e -> Drag (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 "flex-direction" "column"
, style "row-gap" "10px" , style "row-gap" "10px"
] ]

15
frontend/src/Model.elm
View File

@ -2,24 +2,23 @@ module Model exposing
( (
Model Model
, TrackState(..) , TrackState(..)
, Drag(..) , DragState(..)
, DragTarget(..)
) )
import TileMap exposing (ZoomLevel, Coord) import TileMap exposing (ZoomLevel, Coord)
import Point exposing (Point) import Point exposing (Point)
type DragTarget = Map | Graph | StartMark | EndMark type DragState =
DragMap (Int, Int) Coord
type Drag | DragGraph (Int, Int) Float
= None | DragLeftMark (Int, Int) (Float, Float)
| Dragging DragTarget (Int, Int) (Int, Int) | DragRightMark (Int, Int) Float
type TrackState = Empty | Loading | Failure String | Present (List Point) type TrackState = Empty | Loading | Failure String | Present (List Point)
type alias Model = type alias Model =
{ centre: Coord { centre: Coord
, zoom: ZoomLevel , zoom: ZoomLevel
, drag: Drag , drag: Maybe DragState
, startTime : Float , startTime : Float
, duration : Float , duration : Float
, markedTime : (Float, Float) , markedTime : (Float, Float)