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/src/Lib.elm frontend/src/Point.elm
+frontend/frontend.js: frontend/src/Main.elm
 	elm make --output=$@ $<

default.nix

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

frontend/src/Lib.elm

@@ -1,47 +0,0 @@
--- 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,20 +4,18 @@ 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, on)
+import Html.Events exposing (onClick)
 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, line)
+import Svg exposing (Svg, svg, rect, circle, g, polyline)
 import Svg.Attributes as S exposing
     ( viewBox
     , preserveAspectRatio
     , transform
     , x, y
-    , x1, y1 , x2, y2
     , r, rx, ry
     , cx, cy
     , fill
@@ -55,18 +53,7 @@ main =
 type alias Coord = { x: Float, y: Float }
 
 -- zoom level
-type alias ZoomLevel = Int
+type alias Zoom = 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 }
 
@@ -99,20 +86,20 @@ reflect c = Coord -c.x -c.y
 translate base offset =
     { base | x = (base.x + offset.x), y = (base.y + offset.y) }
 
-translatePixels : Coord -> ZoomLevel -> (Int, Int) -> Coord
+translatePixels : Coord -> Zoom -> (Int, Int) -> Coord
 translatePixels old z (x, y) = translate old (pixelsToCoord z (x, y))
 
 
-tileCovering : Coord -> ZoomLevel -> TileNumber
+tileCovering : Coord -> Zoom -> TileNumber
 tileCovering c z =
     TileNumber (truncate (toFloat (2 ^ z) * c.x)) (truncate (toFloat (2 ^ z) * c.y))
 
-pixelFromCoord : Coord -> ZoomLevel -> (Int, Int)
+pixelFromCoord : Coord -> Zoom -> (Int, Int)
 pixelFromCoord c z =
     let {x,y} = tileCovering c (z + 8)
     in (x,y)
 
-boundingTiles : Coord -> ZoomLevel -> Int -> Int -> (TileNumber, TileNumber)
+boundingTiles : Coord -> Zoom -> 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`
@@ -142,7 +129,7 @@ dragDelta d =
 type TrackState = Empty | Loading | Failure String | Present (List Point)
 type alias Model =
     { centre: Coord
-    , zoom: FineZoomLevel
+    , zoom: Zoom
     , drag: Drag
     , startTime : Int
     , duration : Int
@@ -155,7 +142,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 start duration Empty),
+        ((Model (toCoord 51.60 -0.01) 13 None start duration Empty),
              (fetchTrack start duration))
 
 -- SUBSCRIPTIONS
@@ -177,14 +164,12 @@ fetchTrack start duration = Http.get
 -- UPDATE
 
 type Msg
-  = MapZoomIn
+  = ZoomIn
-  | MapZoomOut
+  | ZoomOut
-  | MapScale Float
   | Scroll Int Int
   | PointerDown (Int, Int)
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
-  | TimeScale (Float)
   | Loaded (Result Http.Error (List Point))
   | NewUrlRequest
   | UrlChanged
@@ -196,17 +181,14 @@ update msg model = (newModel msg model, Cmd.none)
 
 newModel msg model =
     case msg of
-        MapZoomIn ->
+        ZoomIn ->
-            { model | zoom = incZoom model.zoom zoomStep }
+            { model | zoom = model.zoom + 1 }
 
-        MapZoomOut ->
+        ZoomOut ->
-            { model | zoom = incZoom model.zoom -zoomStep }
+            { model | zoom = model.zoom - 1 }
 
-        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) }
+            { model | centre = translatePixels model.centre model.zoom (x,y) }
 
         PointerDown (x,y) ->
             { model | drag = Dragging (x,y) (x,y) }
@@ -216,16 +198,7 @@ newModel msg model =
 
         PointerUp (x,y) ->
             { model | drag = None,
-                  centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) }
+                  centre = translatePixels model.centre 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
@@ -237,7 +210,7 @@ newModel msg model =
 
 -- VIEW
 
-tileUrl : TileNumber -> ZoomLevel -> String
+tileUrl : TileNumber -> Zoom -> String
 tileUrl {x,y} z =
     String.concat ["https://a.tile.openstreetmap.org",
                        "/", String.fromInt z,
@@ -254,7 +227,6 @@ 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
@@ -264,69 +236,36 @@ measureView title colour fn allPoints =
                            (String.fromFloat c) ++ ", "
                        Nothing -> ""
         maxY = List.foldr max 0 (List.filterMap fn filteredPoints)
-        minY = List.foldr min maxY (List.filterMap fn filteredPoints)
+        smaxY = String.fromFloat maxY
-        (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 graphHeight
+        , height 200
         , preserveAspectRatio "none"
         ]
-        [ rect
+        [ g
-              [ x "0"
-              , width portalWidth
-              , height graphHeight
-              , fill "#eef"
-              , stroke "none"
-              ] []
-        , g
           [ stroke colour
           , strokeWidth "2"
           , transform ( "scale(" ++ (String.fromFloat (portalWidth / maxX)) ++
-                            ", " ++ (String.fromFloat (graphHeight / rangeYaxis)) ++")" ++
+                            ", " ++ (String.fromFloat (200 / maxY)) ++")" ++
-                            "translate(0, " ++ (String.fromFloat maxYaxis) ++") scale(1, -1)")
+                            "translate(0, " ++ (String.fromFloat maxY) ++") scale(1, -1)")
           ]
-          [ ybar 0
+          [
-          , ybar 1
+           polyline
-          , ybar 2
-          , ybar 3
-          , polyline
                [ fill "none"
                , style "vector-effect" "non-scaling-stroke"
                , S.points string
                ] []
           ]
         , Svg.text_
-          [ x "99%", y "12%"
+          [ x "97%", y "90%"
           , 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
@@ -338,7 +277,7 @@ powerView = measureView "power" "#994444" (.power >> Maybe.map toFloat)
 eleView = measureView "elevation" "#4444ee" (.pos >> .ele)
 
 
-trackView : Int -> Int -> ZoomLevel -> List Point -> Svg Msg
+trackView : Int -> Int -> Zoom -> List Point -> Svg Msg
 trackView leftedge topedge zoom points =
     let plot p =
             let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) zoom
@@ -375,18 +314,15 @@ tiles xs ys zoom =
              (List.map (\ x -> tileImg zoom (TileNumber x y)) xs))
         ys
 
-ifTrack : Model -> (List Point ->  Html msg) ->  Html msg
+ifTrack track content =
-ifTrack model content =
+    case track of
-    case model.track of
+        Present t -> content t
-        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 model =
+canvas centre zoom width height track =
     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
@@ -400,7 +336,7 @@ canvas centre zoom width height model =
         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 model (trackView leftedge topedge zoom)
+        tv = ifTrack track (trackView leftedge topedge zoom)
     in  div [style "position" "absolute"
             ,style "width" (px pixWidth)
             ,style "height" (px pixHeight)
@@ -415,28 +351,12 @@ canvas centre zoom width height model =
 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 (toZoom model.zoom) (dragDelta model.drag))
+    let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta model.drag))
-        canvasV = canvas coord (toZoom model.zoom) portalWidth portalHeight model
+        canvasV = canvas coord model.zoom portalWidth portalHeight model.track
-    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)
@@ -444,10 +364,10 @@ viewDiv model =
                     , style "position" "relative"
                     , style "overflow" "hidden"]
                     [canvasV]
-              , text ("Zoom level " ++ (String.fromInt (toZoom model.zoom)))
+              , text ("Zoom level " ++ (String.fromInt model.zoom))
               , span []
-                  [ button [ onClick MapZoomOut ] [ text "-" ]
+                  [ button [ onClick ZoomOut ] [ text "-" ]
-                  , button [ onClick MapZoomIn ] [ text "+" ]
+                  , button [ onClick ZoomIn ] [ text "+" ]
                   , button [ onClick (Scroll 0 -10) ] [ text "^" ]
                   , button [ onClick (Scroll 0 10) ] [ text "V" ]
                   , button [ onClick (Scroll -10 0) ] [ text "<" ]
@@ -455,13 +375,10 @@ viewDiv model =
                   ]
               ]
         , div [ style "display" "flex"
-              , Html.Events.custom "wheel" timeWheelDecoder
+              , style "flex-direction" "column"]
-              , style "flex-direction" "column"
+            [ div [] [ ifTrack model.track cadenceView ]
-              , style "row-gap" "10px"
+            , div [] [ ifTrack model.track powerView ]
-              ]
+            , 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, subseq)
+module Point exposing(Pos, Point, decoder, downsample, duration)
 
 import Json.Decode as D
 
@@ -62,13 +62,3 @@ 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

@@ -1,31 +0,0 @@
-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, subseq)
+import Point exposing (Point, Pos, downsample)
 import Test exposing (..)
 import Expect exposing (Expectation)
 
@@ -19,34 +19,17 @@ maybe default val =
 
 specs: Test
 specs =
-    describe "Point"
+    describe "downsample"
-        [ describe "downsample"
+        [ test "it returns no more points than requested" <|
-              [ test "it returns no more points than requested" <|
+              \_ ->
-                    \_ ->
+              let orig = (points 10)
-                    let orig = (points 10)
+                  sampled = Point.downsample 5 orig
-                        sampled = Point.downsample 5 orig
+              in Expect.equal 5 (List.length sampled)
-                    in Expect.equal 5 (List.length sampled)
+        , test "it drops points which are too close together" <|
-              , test "it drops points which are too close together" <|
+              \_ ->
-                  \_ ->
+              let orig = List.map newPoint [ 0, 1, 2, 3, 4, 10, 500, 1000 ]
-                      let orig = List.map newPoint [ 0, 1, 2, 3, 4, 10, 500, 1000 ]
+                  sampled = Point.downsample 10 orig
-                          sampled = Point.downsample 10 orig
+                  idx p = maybe 0 p.power
-                          idx p = maybe 0 p.power
+              in Expect.equalLists [0, 500, 1000] (List.map idx sampled)
-                      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) []
-            ]
         ]