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
This commit is contained in:
parent
dfe0a7dbd5
commit
ddd461dc8d
@ -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"
|
||||
]
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user