make the wheel zoom less sensitive

frontend/src/Main.elm

@@ -54,6 +54,23 @@ type alias Coord = { x: Float, y: Float }
 
 -- zoom level
 type alias ZoomLevel = Int
+type FineZoomLevel = FineZoomLevel Int
+
+zoomStep = 8
+
+toZoom : FineZoomLevel -> ZoomLevel
+toZoom (FineZoomLevel f) = f // zoomStep
+
+clamp min max val =
+    if val < min
+    then min
+    else if val > max
+        then max
+        else val
+
+incZoom : FineZoomLevel -> Int -> FineZoomLevel
+incZoom (FineZoomLevel z) delta =
+    FineZoomLevel (clamp 0 (20 * zoomStep) (z + delta))
 
 type alias TileNumber = { x: Int, y: Int }
 
@@ -129,7 +146,7 @@ dragDelta d =
 type TrackState = Empty | Loading | Failure String | Present (List Point)
 type alias Model =
     { centre: Coord
-    , zoom: ZoomLevel
+    , zoom: FineZoomLevel
     , drag: Drag
     , startTime : Int
     , duration : Int
@@ -142,7 +159,7 @@ init _ url navKey =
                 Just (Timeline (Just s) (Just d)) -> (s, d)
                 _ -> (10,10)
     in
-        ((Model (toCoord 51.60 -0.01) 13 None start duration Empty),
+        ((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None start duration Empty),
              (fetchTrack start duration))
 
 -- SUBSCRIPTIONS
@@ -180,28 +197,21 @@ update : Msg -> Model -> (Model, Cmd Msg)
 
 update msg model = (newModel msg model, Cmd.none)
 
-clamp min max val =
-    if val < min
-    then min
-    else if val > max
-        then max
-        else val
-
 newModel msg model =
     case msg of
         MapZoomIn ->
-            { model | zoom = clamp 0 20 (model.zoom + 1) }
+            { model | zoom = incZoom model.zoom zoomStep }
 
         MapZoomOut ->
-            { model | zoom = clamp 0 20 (model.zoom - 1) }
+            { model | zoom = incZoom model.zoom -zoomStep }
 
         MapZoomWheel x y delta ->
             let dir = if y > 0
                       then -1
                       else 1
-            in { model | zoom = clamp 0 20 (model.zoom + dir) }
+            in { model | zoom = incZoom model.zoom dir }
         Scroll x y ->
-            { model | centre = translatePixels model.centre model.zoom (x,y) }
+            { model | centre = translatePixels model.centre (toZoom model.zoom) (x,y) }
 
         PointerDown (x,y) ->
             { model | drag = Dragging (x,y) (x,y) }
@@ -211,7 +221,7 @@ newModel msg model =
 
         PointerUp (x,y) ->
             { model | drag = None,
-                  centre = translatePixels model.centre model.zoom (dragDelta model.drag) }
+                  centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) }
 
         Loaded result ->
             case result of
@@ -373,8 +383,8 @@ wheelDecoder =
 
 viewDiv : Model -> Html Msg
 viewDiv model =
-    let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta model.drag))
+    let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta model.drag))
-        canvasV = canvas coord model.zoom portalWidth portalHeight model.track
+        canvasV = canvas coord (toZoom model.zoom) portalWidth portalHeight model.track
     in div [ style "display" "flex" ]
         [ div [ style "display" "flex"
               , on "wheel" wheelDecoder
@@ -385,7 +395,7 @@ viewDiv model =
                     , style "position" "relative"
                     , style "overflow" "hidden"]
                     [canvasV]
-              , text ("Zoom level " ++ (String.fromInt model.zoom))
+              , text ("Zoom level " ++ (String.fromInt (toZoom model.zoom)))
               , span []
                   [ button [ onClick MapZoomOut ] [ text "-" ]
                   , button [ onClick MapZoomIn ] [ text "+" ]