diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 0b19984..0355696 100644 --- 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 index 289f11b..de95cc6 100644 --- 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)