add scroll mouse for graphs to zoom in/out

which doesn't require but subsequently ignore x and mode fields

Makefile

@@ -3,5 +3,5 @@ default: frontend/frontend.js dist-newstyle/build/x86_64-linux/ghc-9.6.5/souples
 dist-newstyle/build/x86_64-linux/ghc-9.6.5/souplesse-0.1.0.0/x/souplesse/build/souplesse/souplesse: app/*.hs lib/*.hs
 	cabal build
 
-frontend/frontend.js: frontend/src/Main.elm
+frontend/frontend.js: frontend/src/Main.elm frontend/src/Lib.elm frontend/src/Point.elm
 	elm make --output=$@ $<

default.nix

@@ -13,6 +13,7 @@ let
 in haskellEnv.overrideAttrs(o: {
   buildInputs = o.buildInputs ++
                 (with pkgs.elmPackages; [
+                  pkgs.entr
                   elm
                   elm-format
                   elm-optimize-level-2

frontend/src/Lib.elm

@@ -0,0 +1,47 @@
+-- miscellaneous functions extracted from Main so
+-- we can more easily test them
+
+module Lib exposing(looseLabels)
+
+
+maybe default val =
+    case val of
+        Just v -> v
+        Nothing -> default
+
+-- https://github.com/cenfun/nice-ticks/blob/master/docs/Nice-Numbers-for-Graph-Labels.pdf
+
+log10 x = logBase 10 x
+expt b x = b^(toFloat x)
+
+niceNumber x round =
+    let exp = floor (log10 x)
+        f = x / (expt 10.0 exp)
+        nfRound = if f < 1.5
+                  then 1
+                  else if f < 3
+                       then 2
+                       else if f < 7
+                            then 5
+                            else 10
+        nf = if f <= 1
+             then 1
+             else if f <= 2
+                  then 2
+                  else if f <= 5
+                       then 5
+                       else 10
+    in
+        if round
+        then
+            nfRound * expt 10 exp
+        else
+            nf * expt 10 exp
+
+looseLabels ticks min max =
+    let
+        range = niceNumber (max-min) False
+        d = niceNumber (range/(ticks - 1)) True
+        graphmin = toFloat (floor  (min/d)) * d
+        graphmax = toFloat (ceiling (max/d)) * d
+    in (graphmin, graphmax, d)

frontend/src/Main.elm

@@ -4,18 +4,20 @@ import Browser
 import Browser.Navigation as Nav
 import Html exposing (Html, button, div, span, text, img, pre)
 import Html.Attributes as H exposing (src, style, width, height)
-import Html.Events exposing (onClick)
+import Html.Events exposing (onClick, on)
 import Html.Events.Extra.Pointer as Pointer
 import Maybe exposing (Maybe)
+import Lib exposing(..)
 import Json.Decode as D
 import Http
 import Point exposing(Point, Pos ,decoder)
-import Svg exposing (Svg, svg, rect, circle, g, polyline)
+import Svg exposing (Svg, svg, rect, circle, g, polyline, line)
 import Svg.Attributes as S exposing
     ( viewBox
     , preserveAspectRatio
     , transform
     , x, y
+    , x1, y1 , x2, y2
     , r, rx, ry
     , cx, cy
     , fill
@@ -53,7 +55,18 @@ main =
 type alias Coord = { x: Float, y: Float }
 
 -- zoom level
-type alias Zoom = Int
+type alias ZoomLevel = Int
+type FineZoomLevel = FineZoomLevel Int
+
+zoomStep = 8
+
+toZoom : FineZoomLevel -> ZoomLevel
+toZoom (FineZoomLevel f) = f // zoomStep
+
+
+incZoom : FineZoomLevel -> Int -> FineZoomLevel
+incZoom (FineZoomLevel z) delta =
+    FineZoomLevel (clamp 0 (20 * zoomStep) (z + delta))
 
 type alias TileNumber = { x: Int, y: Int }
 
@@ -86,20 +99,20 @@ reflect c = Coord -c.x -c.y
 translate base offset =
     { base | x = (base.x + offset.x), y = (base.y + offset.y) }
 
-translatePixels : Coord -> Zoom -> (Int, Int) -> Coord
+translatePixels : Coord -> ZoomLevel -> (Int, Int) -> Coord
 translatePixels old z (x, y) = translate old (pixelsToCoord z (x, y))
 
 
-tileCovering : Coord -> Zoom -> TileNumber
+tileCovering : Coord -> ZoomLevel -> TileNumber
 tileCovering c z =
     TileNumber (truncate (toFloat (2 ^ z) * c.x)) (truncate (toFloat (2 ^ z) * c.y))
 
-pixelFromCoord : Coord -> Zoom -> (Int, Int)
+pixelFromCoord : Coord -> ZoomLevel -> (Int, Int)
 pixelFromCoord c z =
     let {x,y} = tileCovering c (z + 8)
     in (x,y)
 
-boundingTiles : Coord -> Zoom -> Int -> Int -> (TileNumber, TileNumber)
+boundingTiles : Coord -> ZoomLevel -> Int -> Int -> (TileNumber, TileNumber)
 boundingTiles centre z width height =
     -- find the tiles needed to cover the area (`width` x `height`)
     -- about the point at `centre`
@@ -129,7 +142,7 @@ dragDelta d =
 type TrackState = Empty | Loading | Failure String | Present (List Point)
 type alias Model =
     { centre: Coord
-    , zoom: Zoom
+    , zoom: FineZoomLevel
     , drag: Drag
     , startTime : Int
     , duration : Int
@@ -142,7 +155,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
@@ -164,12 +177,14 @@ fetchTrack start duration = Http.get
 -- UPDATE
 
 type Msg
-  = ZoomIn
+  = MapZoomIn
-  | ZoomOut
+  | MapZoomOut
+  | MapScale Float
   | Scroll Int Int
   | PointerDown (Int, Int)
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
+  | TimeScale (Float)
   | Loaded (Result Http.Error (List Point))
   | NewUrlRequest
   | UrlChanged
@@ -181,14 +196,17 @@ update msg model = (newModel msg model, Cmd.none)
 
 newModel msg model =
     case msg of
-        ZoomIn ->
+        MapZoomIn ->
-            { model | zoom = model.zoom + 1 }
+            { model | zoom = incZoom model.zoom zoomStep }
 
-        ZoomOut ->
+        MapZoomOut ->
-            { model | zoom = model.zoom - 1 }
+            { 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 model.zoom (x,y) }
+            { model | centre = translatePixels model.centre (toZoom model.zoom) (x,y) }
 
         PointerDown (x,y) ->
             { model | drag = Dragging (x,y) (x,y) }
@@ -198,7 +216,16 @@ 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) }
+
+        TimeScale factor ->
+            let fudge = factor
+                len = model.duration - floor(fudge)
+            in { model |
+                     startTime = model.startTime + floor(fudge / 2)
+               ,     duration = len
+               }
+
 
         Loaded result ->
             case result of
@@ -210,7 +237,7 @@ newModel msg model =
 
 -- VIEW
 
-tileUrl : TileNumber -> Zoom -> String
+tileUrl : TileNumber -> ZoomLevel -> String
 tileUrl {x,y} z =
     String.concat ["https://a.tile.openstreetmap.org",
                        "/", String.fromInt z,
@@ -227,6 +254,7 @@ type alias Colour = String
 measureView : String -> Colour -> (Point -> Maybe Float) -> List Point -> Svg Msg
 measureView title colour fn allPoints =
     let filteredPoints = Point.downsample 300 allPoints
+        graphHeight = 180
         startTime = case allPoints of
                         (p::_) -> p.time
                         _ -> 0
@@ -236,36 +264,69 @@ measureView title colour fn allPoints =
                            (String.fromFloat c) ++ ", "
                        Nothing -> ""
         maxY = List.foldr max 0 (List.filterMap fn filteredPoints)
-        smaxY = String.fromFloat maxY
+        minY = List.foldr min maxY (List.filterMap fn filteredPoints)
+        (minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY
+        rangeYaxis = maxYaxis - minYaxis
         maxX = Point.duration allPoints
-        smaxX = String.fromFloat maxX
         string = String.concat (List.map coords filteredPoints)
+        ybar n = line
+                 [ fill "none"
+                 , style "vector-effect" "non-scaling-stroke"
+                 , strokeWidth "1"
+                 , stroke "#aaa"
+                 , x1 "0"
+                 , y1 (String.fromFloat (minYaxis + n * tickY))
+                 , x2 (String.fromFloat (0.95 * maxX))
+                 , y2 (String.fromFloat (minYaxis + n * tickY))
+                 ] []
+        ylabel n = Svg.text_
+          [ x "99%", y (String.fromFloat (graphHeight - graphHeight * n * (tickY/rangeYaxis)))
+          , style "text-anchor" "end"
+          , style "fill" "#222244"
+          ] [ Svg.text (String.fromFloat (minYaxis + n * tickY)) ]
+
     in
         svg
         [ width portalWidth
-        , height 200
+        , height graphHeight
         , preserveAspectRatio "none"
         ]
-        [ g
+        [ rect
+              [ x "0"
+              , width portalWidth
+              , height graphHeight
+              , fill "#eef"
+              , stroke "none"
+              ] []
+        , g
           [ stroke colour
           , strokeWidth "2"
           , transform ( "scale(" ++ (String.fromFloat (portalWidth / maxX)) ++
-                            ", " ++ (String.fromFloat (200 / maxY)) ++")" ++
+                            ", " ++ (String.fromFloat (graphHeight / rangeYaxis)) ++")" ++
-                            "translate(0, " ++ (String.fromFloat maxY) ++") scale(1, -1)")
+                            "translate(0, " ++ (String.fromFloat maxYaxis) ++") scale(1, -1)")
           ]
-          [
+          [ ybar 0
-           polyline
+          , ybar 1
+          , ybar 2
+          , ybar 3
+          , polyline
                [ fill "none"
                , style "vector-effect" "non-scaling-stroke"
                , S.points string
                ] []
           ]
         , Svg.text_
-          [ x "97%", y "90%"
+          [ x "99%", y "12%"
           , style "fill" "#222244"
           , style "text-anchor" "end"
+          , style "font-weight" "bold"
           , style "text-shadow" "2px 2px 1px #dddddd"
-          ] [ Svg.text title ]
+          ] [ Svg.text title
+            ]
+        , ylabel 0
+        , ylabel 1
+        , ylabel 2
+        , ylabel 3
         ]
 
 cadenceView : List Point -> Svg Msg
@@ -277,7 +338,7 @@ powerView = measureView "power" "#994444" (.power >> Maybe.map toFloat)
 eleView = measureView "elevation" "#4444ee" (.pos >> .ele)
 
 
-trackView : Int -> Int -> Zoom -> List Point -> Svg Msg
+trackView : Int -> Int -> ZoomLevel -> List Point -> Svg Msg
 trackView leftedge topedge zoom points =
     let plot p =
             let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) zoom
@@ -314,15 +375,18 @@ tiles xs ys zoom =
              (List.map (\ x -> tileImg zoom (TileNumber x y)) xs))
         ys
 
-ifTrack track content =
+ifTrack : Model -> (List Point ->  Html msg) ->  Html msg
-    case track of
+ifTrack model content =
-        Present t -> content t
+    case model.track of
+        Present t ->
+            let points = Point.subseq t (toFloat model.startTime) (toFloat model.duration)
+            in  content points
         Failure f -> Debug.log f (div [] [ Html.text "failure", Html.text f])
         Loading -> div [] [Html.text "loading"]
         Empty -> div [] [Html.text "no points"]
 
 
-canvas centre zoom width height track =
+canvas centre zoom width height model =
     let (mintile, maxtile) = boundingTiles centre zoom width height
         -- offset is pixel difference between centre (which *should*
         -- be the middle of the image) and actual middle of the canvas
@@ -336,7 +400,7 @@ canvas centre zoom width height track =
         xs = List.range mintile.x maxtile.x
         ys = List.range mintile.y maxtile.y
         epos e = Tuple.mapBoth floor floor e.pointer.clientPos
-        tv = ifTrack track (trackView leftedge topedge zoom)
+        tv = ifTrack model (trackView leftedge topedge zoom)
     in  div [style "position" "absolute"
             ,style "width" (px pixWidth)
             ,style "height" (px pixHeight)
@@ -351,12 +415,28 @@ canvas centre zoom width height track =
 portalWidth = 600
 portalHeight = 600
 
+withSwallowing m =
+    { message = m
+    , stopPropagation = True
+    , preventDefault = True
+    }
+
+-- FIXME should do something useful with deltaMode as well as deltaY
+mapWheelDecoder =
+    D.map (withSwallowing << MapScale) (D.field "deltaY" D.float)
+
+timeWheelDecoder =
+    D.map (withSwallowing << TimeScale) (D.field "deltaY" D.float)
+
 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
-    in div [ style "display" "flex" ]
+    in div [ style "display" "flex"
+           , style "column-gap" "15px"
+           ]
         [ div [ style "display" "flex"
+              , Html.Events.custom "wheel" mapWheelDecoder
               , style "flex-direction" "column"]
               [ div [ style "width" (px portalWidth)
                     , style "height" (px portalHeight)
@@ -364,10 +444,10 @@ 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 ZoomOut ] [ text "-" ]
+                  [ button [ onClick MapZoomOut ] [ text "-" ]
-                  , button [ onClick ZoomIn ] [ text "+" ]
+                  , button [ onClick MapZoomIn ] [ text "+" ]
                   , button [ onClick (Scroll 0 -10) ] [ text "^" ]
                   , button [ onClick (Scroll 0 10) ] [ text "V" ]
                   , button [ onClick (Scroll -10 0) ] [ text "<" ]
@@ -375,10 +455,13 @@ viewDiv model =
                   ]
               ]
         , div [ style "display" "flex"
-              , style "flex-direction" "column"]
+              , Html.Events.custom "wheel" timeWheelDecoder
-            [ div [] [ ifTrack model.track cadenceView ]
+              , style "flex-direction" "column"
-            , div [] [ ifTrack model.track powerView ]
+              , style "row-gap" "10px"
-            , div [] [ ifTrack model.track eleView ]
+              ]
+            [ div [] [ ifTrack model cadenceView ]
+            , div [] [ ifTrack model powerView ]
+            , div [] [ ifTrack model eleView ]
             ]
         ]
 

frontend/src/Point.elm

@@ -1,4 +1,4 @@
-module Point exposing(Pos, Point, decoder, downsample, duration)
+module Point exposing(Pos, Point, decoder, downsample, duration, subseq)
 
 import Json.Decode as D
 
@@ -62,3 +62,13 @@ duration points =
     case points of
         (p::ps) -> (last p ps).time - p.time
         _ -> 0
+
+subseq points start dur =
+    case points of
+        [] -> []
+        (p::ps) ->
+            if p.time < start
+            then subseq ps start dur
+            else if p.time >= (start + dur)
+                 then []
+                 else p::(subseq ps start dur)

frontend/tests/LibTest.elm

@@ -0,0 +1,31 @@
+module LibTest exposing (specs)
+
+import Lib exposing (..)
+import Test exposing (..)
+import Expect exposing (Expectation)
+
+specs: Test
+specs =
+    describe "looseLabels"
+        [ test "0-100" <|
+              \_ ->
+              let (u, v, _) = looseLabels 10 0.0 100.0
+              in Expect.equal (0, 100) (u, v)
+        , test "2-98" <|
+              \_ ->
+              let (u, v, _) = looseLabels 10  2 98
+              in Expect.equal (0, 100) (u, v)
+        , test "8-91" <|
+              \_ ->
+              let (u, v, _) = looseLabels 10  8 91
+              in Expect.equal (0, 100) (u, v)
+        , test "1-32" <|
+              \_ ->
+              let (u, v, _) = looseLabels 8  1 32
+              in Expect.equal (0, 40) (u, v)
+        , test "1-4" <|
+              \_ ->
+              let (u, v, _) = looseLabels 10  1 4
+              in Expect.equal (1, 4) (u, v)
+
+        ]

frontend/tests/PointTest.elm

@@ -1,6 +1,6 @@
 module PointTest exposing (specs)
 
-import Point exposing (Point, Pos, downsample)
+import Point exposing (Point, Pos, downsample, subseq)
 import Test exposing (..)
 import Expect exposing (Expectation)
 
@@ -19,17 +19,34 @@ maybe default val =
 
 specs: Test
 specs =
-    describe "downsample"
+    describe "Point"
-        [ test "it returns no more points than requested" <|
+        [ describe "downsample"
-              \_ ->
+              [ test "it returns no more points than requested" <|
-              let orig = (points 10)
+                    \_ ->
-                  sampled = Point.downsample 5 orig
+                    let orig = (points 10)
-              in Expect.equal 5 (List.length sampled)
+                        sampled = Point.downsample 5 orig
-        , test "it drops points which are too close together" <|
+                    in Expect.equal 5 (List.length sampled)
-              \_ ->
+              , test "it drops points which are too close together" <|
-              let orig = List.map newPoint [ 0, 1, 2, 3, 4, 10, 500, 1000 ]
+                  \_ ->
-                  sampled = Point.downsample 10 orig
+                      let orig = List.map newPoint [ 0, 1, 2, 3, 4, 10, 500, 1000 ]
-                  idx p = maybe 0 p.power
+                          sampled = Point.downsample 10 orig
-              in Expect.equalLists [0, 500, 1000] (List.map idx sampled)
+                          idx p = maybe 0 p.power
-
+                      in Expect.equalLists [0, 500, 1000] (List.map idx sampled)
+              ]
+        , describe "subseq"
+            [ test "chooses only points in the time range" <|
+                  \_ ->
+                  let orig = (points 50)
+                      s = 1731437087
+                      d = 40
+                      subs = subseq orig s d
+                  in Expect.equal True
+                      (List.all (\ p -> p.time >= s && p.time <= s + d) subs)
+            , test "is empty if no points" <|
+                  \_ ->
+                      Expect.equalLists [] (subseq [] 10 10)
+            , test "is empty if no time" <|
+                  \_ ->
+                      Expect.equalLists (subseq (points 50) 1731437067 0) []
+            ]
         ]