diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index dc5c392..b4c5bf3 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -126,27 +126,35 @@ boundingTiles centre z width height = -- MODEL +type DragTarget = Map | Graph | StartMark | EndMark + type Drag = None - | Dragging (Int, Int) (Int, Int) + | Dragging DragTarget (Int, Int) (Int, Int) + dragTo : Drag -> (Int, Int) -> Drag dragTo d dest = case d of None -> None - Dragging from to -> Dragging from dest + Dragging target from to -> Dragging target from dest -dragDelta d = +dragDelta target d = case d of - None -> (0,0) - Dragging (fx,fy) (tx,ty) -> (fx-tx, fy-ty) + 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 - , timeDrag: Drag , startTime : Int , duration : Int , track: TrackState } @@ -158,7 +166,7 @@ init _ url navKey = Just (Timeline (Just s) (Just d)) -> (s, d) _ -> (10,10) in - ((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None None 0 0 Empty), + ((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None 0 0 Empty), (fetchTrack start duration)) -- SUBSCRIPTIONS @@ -181,13 +189,10 @@ fetchTrack start duration = Http.get type Msg = MapScale Int - | MapDragStart (Int, Int) - | MapDrag (Int, Int) - | MapDragFinish (Int, Int) + | DragStart DragTarget (Int, Int) + | Drag (Int, Int) + | DragFinish (Int, Int) | TimeScale (Float) - | TimeDragStart (Int, Int) - | TimeDrag (Int, Int) - | TimeDragFinish (Int, Int) | Loaded (Result Http.Error (List Point)) | NewUrlRequest | UrlChanged @@ -202,16 +207,26 @@ updateModel msg model = MapScale y -> { model | zoom = incZoom model.zoom y } - MapDragStart (x,y) -> - { model | drag = Dragging (x,y) (x,y) } + DragStart target (x,y) -> + { model | drag = Dragging target (x,y) (x,y) } - MapDrag (x,y) -> + Drag (x,y) -> { model | drag = dragTo model.drag (x,y) } - MapDragFinish (x,y) -> - { model | drag = None, - centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) } - + DragFinish (x,y) -> + case model.drag of + Dragging Map start end -> + { 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 + delta * model.duration // portalWidth + } + _ -> model TimeScale factor -> let fudge = factor len = model.duration - floor(fudge) @@ -220,18 +235,6 @@ updateModel msg model = , duration = len } - TimeDragStart (x,y) -> - { model | timeDrag = Dragging (x,y) (x,y) } - - TimeDrag (x,y) -> - { model | timeDrag = dragTo model.timeDrag (x,y) } - - TimeDragFinish (x,y) -> - { model | timeDrag = None, - startTime = - let (delta, _) = dragDelta model.timeDrag - in model.startTime + delta * model.duration // portalWidth - } Loaded result -> case result of Ok trk -> @@ -526,7 +529,7 @@ ifTrack : Model -> (List Point -> Html msg) -> Html msg ifTrack model content = case model.track of Present t -> - let (dt, _) = dragDelta model.timeDrag + let (dt, _) = dragDelta Graph model.drag dpix = dt * model.duration // portalWidth start = toFloat (model.startTime + dpix) points = Point.subseq t start (toFloat model.duration) @@ -557,11 +560,12 @@ canvas centre zoom width height model = ,style "left" (px -offsetX) ,style "top" (px -offsetY) ,style "lineHeight" (px 0) - ,Pointer.onUp (\e -> MapDragFinish (epos e)) - ,Pointer.onMove (\e -> MapDrag (epos e)) - ,Pointer.onDown (\e -> MapDragStart (epos e)) ] + ,Pointer.onUp (\e -> DragFinish (epos e)) + ,Pointer.onMove (\e -> Drag (epos e)) + ,Pointer.onDown (\e -> DragStart Map (epos e)) ] (tv :: tiles xs ys zoom) + portalWidth = 600 portalHeight = 600 @@ -581,7 +585,7 @@ timeWheelDecoder = viewDiv : Model -> Html Msg viewDiv model = - let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta model.drag)) + let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta Map model.drag)) canvasV = canvas coord (toZoom model.zoom) portalWidth portalHeight model epos e = Tuple.mapBoth floor floor e.pointer.clientPos in div [ style "display" "flex" @@ -604,9 +608,9 @@ viewDiv model = ] , div [ style "display" "flex" , Html.Events.custom "wheel" timeWheelDecoder - , Pointer.onUp (\e -> TimeDragFinish (epos e)) - , Pointer.onMove (\e -> TimeDrag (epos e)) - , Pointer.onDown (\e -> TimeDragStart (epos e)) + , Pointer.onUp (\e -> DragFinish (epos e)) + , Pointer.onMove (\e -> Drag (epos e)) + , Pointer.onDown (\e -> DragStart Graph (epos e)) , style "flex-direction" "column" , style "row-gap" "10px" ]