frontend/src/Main.elm

@@ -144,7 +144,6 @@ type alias Model =
     { centre: Coord
     , zoom: FineZoomLevel
     , drag: Drag
-    , timeDrag: Drag
     , startTime : Int
     , duration : Int
     , track: TrackState }
@@ -156,7 +155,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 start duration Empty),
+        ((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None start duration Empty),
              (fetchTrack start duration))
 
 -- SUBSCRIPTIONS
@@ -178,14 +177,14 @@ fetchTrack start duration = Http.get
 -- UPDATE
 
 type Msg
-  = MapScale Int
+  = MapZoomIn
-  | MapDragStart (Int, Int)
+  | MapZoomOut
-  | MapDrag (Int, Int)
+  | MapScale Float
-  | MapDragFinish (Int, Int)
+  | Scroll Int Int
+  | PointerDown (Int, Int)
+  | PointerMove (Int, Int)
+  | PointerUp (Int, Int)
   | TimeScale (Float)
-  | TimeDragStart (Int, Int)
-  | TimeDrag (Int, Int)
-  | TimeDragFinish (Int, Int)
   | Loaded (Result Http.Error (List Point))
   | NewUrlRequest
   | UrlChanged
@@ -197,16 +196,25 @@ update msg model = (newModel msg model, Cmd.none)
 
 newModel msg model =
     case msg of
-        MapScale y ->
+        MapZoomIn ->
-            { model | zoom = incZoom model.zoom y }
+            { model | zoom = incZoom model.zoom zoomStep }
 
-        MapDragStart (x,y) ->
+        MapZoomOut ->
+            { model | zoom = incZoom model.zoom -zoomStep }
+
+        MapScale y ->
+            let dir = floor(abs(y)/y)
+            in { model | zoom = incZoom model.zoom dir }
+        Scroll x y ->
+            { model | centre = translatePixels model.centre (toZoom model.zoom) (x,y) }
+
+        PointerDown (x,y) ->
             { model | drag = Dragging (x,y) (x,y) }
 
-        MapDrag (x,y) ->
+        PointerMove (x,y) ->
             { model | drag = dragTo model.drag (x,y) }
 
-        MapDragFinish (x,y) ->
+        PointerUp (x,y) ->
             { model | drag = None,
                   centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) }
 
@@ -218,18 +226,7 @@ newModel 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 -> { model | track = Present trk }
@@ -382,10 +379,7 @@ ifTrack : Model -> (List Point ->  Html msg) ->  Html msg
 ifTrack model content =
     case model.track of
         Present t ->
-            let (dt, _) = dragDelta model.timeDrag
+            let points = Point.subseq t (toFloat model.startTime) (toFloat model.duration)
-                dpix = dt * model.duration // portalWidth
-                start = toFloat (model.startTime + dpix)
-                points = Point.subseq t start (toFloat model.duration)
             in  content points
         Failure f -> Debug.log f (div [] [ Html.text "failure", Html.text f])
         Loading -> div [] [Html.text "loading"]
@@ -413,9 +407,9 @@ 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.onUp (\e -> PointerUp (epos e))
-            ,Pointer.onMove (\e -> MapDrag (epos e))
+            ,Pointer.onMove (\e -> PointerMove (epos e))
-            ,Pointer.onDown (\e -> MapDragStart (epos e)) ]
+            ,Pointer.onDown (\e -> PointerDown (epos e)) ]
         (tv :: tiles xs ys zoom)
 
 portalWidth = 600
@@ -429,8 +423,7 @@ withSwallowing m =
 
 -- FIXME should do something useful with deltaMode as well as deltaY
 mapWheelDecoder =
-    let sgn x = floor((abs x)/x)
+    D.map (withSwallowing << MapScale) (D.field "deltaY" D.float)
-    in D.map (withSwallowing << MapScale << sgn) (D.field "deltaY" D.float)
 
 timeWheelDecoder =
     D.map (withSwallowing << TimeScale) (D.field "deltaY" D.float)
@@ -439,7 +432,6 @@ viewDiv : Model -> Html Msg
 viewDiv model =
     let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta 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"
            , style "column-gap" "15px"
            ]
@@ -454,15 +446,16 @@ viewDiv model =
                     [canvasV]
               , text ("Zoom level " ++ (String.fromInt (toZoom model.zoom)))
               , span []
-                  [ button [ onClick (MapScale -zoomStep) ] [ text "-" ]
+                  [ button [ onClick MapZoomOut ] [ text "-" ]
-                  , button [ onClick (MapScale zoomStep) ] [ text "+" ]
+                  , button [ onClick MapZoomIn ] [ text "+" ]
+                  , button [ onClick (Scroll 0 -10) ] [ text "^" ]
+                  , button [ onClick (Scroll 0 10) ] [ text "V" ]
+                  , button [ onClick (Scroll -10 0) ] [ text "<" ]
+                  , button [ onClick (Scroll 10 0) ] [ text ">" ]
                   ]
               ]
         , 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))
               , style "flex-direction" "column"
               , style "row-gap" "10px"
               ]