619 lines
19 KiB
Elm
619 lines
19 KiB
Elm
module Main exposing (view)
|
|
|
|
import Browser
|
|
import Browser.Navigation as Nav
|
|
import Html exposing (Html, button, div, span, text, img)
|
|
import Html.Attributes as H exposing (src, style, width, height)
|
|
import Html.Events exposing (onClick, on)
|
|
import Html.Events.Extra.Pointer as Pointer
|
|
import Maybe exposing (Maybe)
|
|
import Lib exposing(..)
|
|
import List.Extra exposing(find)
|
|
import Json.Decode as D
|
|
import Http
|
|
import Point exposing(Point, Pos ,decoder)
|
|
import Svg exposing (Svg, svg, rect, g, polyline, line)
|
|
import Svg.Attributes as S exposing
|
|
( viewBox
|
|
, preserveAspectRatio
|
|
, transform
|
|
, x, y
|
|
, x1, y1 , x2, y2
|
|
, fill
|
|
, stroke, strokeWidth, strokeOpacity)
|
|
import Time -- exposing(Posix)
|
|
import Url.Parser exposing (Parser, (<?>), int, map, s, string)
|
|
import Url.Parser.Query as Query
|
|
import Url exposing (Url)
|
|
|
|
|
|
type Route = Timeline (Maybe Int) (Maybe Int)
|
|
|
|
routeParser : Parser (Route -> a) a
|
|
routeParser =
|
|
map Timeline (s "timeline" <?> Query.int "start" <?> Query.int "duration")
|
|
|
|
|
|
-- MAIN
|
|
|
|
|
|
main =
|
|
Browser.application
|
|
{ init = init
|
|
, update = update
|
|
, subscriptions = subscriptions
|
|
, onUrlRequest = \ _ -> NewUrlRequest
|
|
, onUrlChange = \ _ -> UrlChanged
|
|
, view = view }
|
|
|
|
-- MATHS
|
|
|
|
-- Coordinates in a Mercator projection
|
|
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
|
|
|
|
|
|
incZoom : FineZoomLevel -> Int -> FineZoomLevel
|
|
incZoom (FineZoomLevel z) delta =
|
|
FineZoomLevel (clamp 0 (20 * zoomStep) (z + delta))
|
|
|
|
type alias TileNumber = { x: Int, y: Int }
|
|
|
|
-- project lat/long to co-ordinates based on pseudocode at
|
|
-- https://wiki.openstreetmap.org/wiki/Slippy_map_tilenames#Zoom_levels
|
|
|
|
sec x = 1 / (cos x)
|
|
|
|
toCoord : Pos -> Coord
|
|
toCoord pos =
|
|
let
|
|
lat_rad = pos.lat * pi / 180
|
|
x = (pos.lon + 180) / 360
|
|
y = (1 - (logBase e ((tan lat_rad) + (sec lat_rad))) / pi) / 2
|
|
in
|
|
Coord x y
|
|
|
|
pixelsToCoord z (x,y) =
|
|
let x_float = toFloat x / toFloat ( 2 ^ (z + 8))
|
|
y_float = toFloat y / toFloat ( 2 ^ (z + 8))
|
|
in Coord x_float y_float
|
|
|
|
reflect : Coord -> Coord
|
|
reflect c = Coord -c.x -c.y
|
|
|
|
-- translate : a -> a -> a
|
|
translate base offset =
|
|
{ base | x = (base.x + offset.x), y = (base.y + offset.y) }
|
|
|
|
translatePixels : Coord -> ZoomLevel -> (Int, Int) -> Coord
|
|
translatePixels old z (x, y) = translate old (pixelsToCoord z (x, y))
|
|
|
|
|
|
tileCovering : Coord -> ZoomLevel -> TileNumber
|
|
tileCovering c z =
|
|
TileNumber (truncate (toFloat (2 ^ z) * c.x)) (truncate (toFloat (2 ^ z) * c.y))
|
|
|
|
pixelFromCoord : Coord -> ZoomLevel -> (Int, Int)
|
|
pixelFromCoord c z =
|
|
let {x,y} = tileCovering c (z + 8)
|
|
in (x,y)
|
|
|
|
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`
|
|
let delta = pixelsToCoord z ((width // 2), (height // 2))
|
|
minCoord = translate centre (reflect delta)
|
|
maxCoord = translate centre delta
|
|
in ((tileCovering minCoord z),
|
|
(translate (tileCovering maxCoord z) (TileNumber 1 1)))
|
|
|
|
-- MODEL
|
|
|
|
type DragTarget = Map | Graph | StartMark | EndMark
|
|
|
|
type Drag
|
|
= None
|
|
| Dragging DragTarget (Int, Int) (Int, Int)
|
|
|
|
|
|
dragTo : Drag -> (Int, Int) -> Drag
|
|
dragTo d dest =
|
|
case d of
|
|
None -> None
|
|
Dragging target from _ -> Dragging target from dest
|
|
|
|
dragDelta target d =
|
|
case d of
|
|
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
|
|
, startTime : Int
|
|
, duration : Int
|
|
, track: TrackState }
|
|
|
|
init : () -> Url -> Nav.Key -> (Model, Cmd Msg)
|
|
init _ url navKey =
|
|
let (start, duration) =
|
|
case Url.Parser.parse routeParser url of
|
|
Just (Timeline (Just s) (Just d)) -> (s, d)
|
|
_ -> (10,10)
|
|
in
|
|
((Model
|
|
(toCoord (Pos 0 0 Nothing))
|
|
(FineZoomLevel (1*8)) None 0 0 Loading),
|
|
(fetchTrack start duration))
|
|
|
|
-- SUBSCRIPTIONS
|
|
|
|
subscriptions : Model -> Sub Msg
|
|
subscriptions model = Sub.none
|
|
|
|
|
|
fetchTrack start duration = Http.get
|
|
{ url = ("http://localhost:3000/points?start=" ++
|
|
String.fromInt start ++
|
|
"&duration=" ++
|
|
String.fromInt duration)
|
|
, expect = Http.expectJson Loaded (D.list Point.decoder)
|
|
}
|
|
|
|
|
|
|
|
-- UPDATE
|
|
|
|
type Msg
|
|
= MapScale Int
|
|
| DragStart DragTarget (Int, Int)
|
|
| Drag (Int, Int)
|
|
| DragFinish (Int, Int)
|
|
| TimeScale (Float)
|
|
| Loaded (Result Http.Error (List Point))
|
|
| NewUrlRequest
|
|
| UrlChanged
|
|
| Dribble String
|
|
|
|
|
|
update : Msg -> Model -> (Model, Cmd Msg)
|
|
|
|
update msg model = (updateModel msg model, Cmd.none)
|
|
|
|
updateModel msg model =
|
|
case msg of
|
|
MapScale y ->
|
|
{ model | zoom = incZoom model.zoom y }
|
|
|
|
DragStart target (x,y) ->
|
|
{ model | drag = Dragging target (x,y) (x,y) }
|
|
|
|
Drag (x,y) ->
|
|
{ model | drag = dragTo model.drag (x,y) }
|
|
|
|
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)
|
|
in { model |
|
|
startTime = model.startTime + floor(fudge / 2)
|
|
, duration = len
|
|
}
|
|
|
|
Loaded result ->
|
|
case result of
|
|
Ok trk ->
|
|
let start = Maybe.withDefault 0 (Point.startTime trk)
|
|
duration = Point.duration trk
|
|
in
|
|
{ model
|
|
| track = Present trk
|
|
, centre = toCoord (Point.centre trk)
|
|
, zoom = FineZoomLevel ( 13 * 8)
|
|
, startTime = floor start
|
|
, duration = ceiling duration
|
|
}
|
|
Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") }
|
|
Err e -> { model | track = Debug.log "unknown error" (Failure "e") }
|
|
NewUrlRequest -> model
|
|
UrlChanged -> model
|
|
Dribble message ->
|
|
let _ = Debug.log "dribble" message
|
|
in model
|
|
|
|
|
|
-- VIEW
|
|
|
|
formatTime epoch =
|
|
let utc = Time.utc
|
|
time = Time.millisToPosix <| floor(epoch * 1000)
|
|
zeroed i = String.padLeft 2 '0' (String.fromInt i)
|
|
in String.fromInt (Time.toHour utc time)
|
|
++ ":" ++
|
|
zeroed (Time.toMinute utc time)
|
|
++ ":" ++
|
|
zeroed (Time.toSecond utc time)
|
|
|
|
timeTick duration =
|
|
let width = duration / 6
|
|
candidates =
|
|
[ 1
|
|
, 3
|
|
, 5
|
|
, 10
|
|
, 15
|
|
, 30
|
|
, 60
|
|
, 60 * 3
|
|
, 60 * 5
|
|
, 60 * 10
|
|
, 60 * 15
|
|
, 60 * 30
|
|
, 60 * 60
|
|
]
|
|
in case List.Extra.find (\ candidate -> width <= candidate) candidates of
|
|
Just n -> n
|
|
Nothing -> width
|
|
|
|
tileUrl : TileNumber -> ZoomLevel -> String
|
|
tileUrl {x,y} z =
|
|
String.concat ["https://a.tile.openstreetmap.org",
|
|
"/", String.fromInt z,
|
|
"/", String.fromInt x,
|
|
"/", String.fromInt y,
|
|
".png" ]
|
|
|
|
tileImg zoom tilenumber = img [ width 256,
|
|
height 256,
|
|
src (tileUrl tilenumber zoom) ] []
|
|
|
|
type alias Colour = String
|
|
|
|
measureView : String -> Colour -> (Point -> Maybe Float) -> List Point -> Svg Msg
|
|
measureView title colour fn points =
|
|
let graphHeight = 180
|
|
startTime = Maybe.withDefault 0 (Point.startTime points)
|
|
coords p = case (fn p) of
|
|
Just c ->
|
|
(String.fromFloat (p.time - startTime)) ++ "," ++
|
|
(String.fromFloat c) ++ ", "
|
|
Nothing -> ""
|
|
maxY = List.foldr max 0 (List.filterMap fn points)
|
|
minY = List.foldr min maxY (List.filterMap fn points)
|
|
(minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY
|
|
rangeYaxis = maxYaxis - minYaxis
|
|
maxX = Point.duration points
|
|
string = String.concat (List.map coords points)
|
|
ttick = timeTick maxX
|
|
firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
|
|
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))
|
|
] []
|
|
xtick n =
|
|
let t = firstTimeTick + n * timeTick maxX
|
|
xpix = t * portalWidth/maxX
|
|
label = formatTime (t + startTime)
|
|
in
|
|
g []
|
|
[ line
|
|
[ fill "none"
|
|
, style "vector-effect" "non-scaling-stroke"
|
|
, strokeWidth "1"
|
|
, stroke "#aaa"
|
|
, x1 (String.fromFloat xpix)
|
|
, y1 "0"
|
|
, x2 (String.fromFloat xpix)
|
|
, y2 "180"
|
|
] []
|
|
]
|
|
|
|
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
|
|
, preserveAspectRatio "none"
|
|
]
|
|
[ rect
|
|
[ 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)) ++")" ++
|
|
"translate(0, " ++ (String.fromFloat maxYaxis) ++") scale(1, -1)")
|
|
]
|
|
[ ybar 0
|
|
, ybar 1
|
|
, ybar 2
|
|
, ybar 3
|
|
, polyline
|
|
[ fill "none"
|
|
, style "vector-effect" "non-scaling-stroke"
|
|
, S.points string
|
|
] []
|
|
]
|
|
, Svg.text_
|
|
[ 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
|
|
]
|
|
, ylabel 0
|
|
, ylabel 1
|
|
, ylabel 2
|
|
, ylabel 3
|
|
, xtick 0
|
|
, xtick 1
|
|
, xtick 2
|
|
, xtick 3
|
|
, xtick 4
|
|
, xtick 5
|
|
]
|
|
|
|
timeClickDecoder =
|
|
D.map Dribble (D.at ["target", "id"] D.string)
|
|
|
|
timeAxis points =
|
|
let graphHeight = 30
|
|
startTime = Maybe.withDefault 0 (Point.startTime points)
|
|
maxX = Point.duration points
|
|
ttick = timeTick maxX
|
|
firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
|
|
xtick n =
|
|
let t = firstTimeTick + (toFloat n) * timeTick maxX
|
|
xpix = t * portalWidth/maxX
|
|
label = formatTime (t + startTime)
|
|
in
|
|
g []
|
|
[ line
|
|
[ fill "none"
|
|
, style "vector-effect" "non-scaling-stroke"
|
|
, strokeWidth "1"
|
|
, stroke "#333"
|
|
, x1 (String.fromFloat xpix)
|
|
, y1 "0"
|
|
, x2 (String.fromFloat xpix)
|
|
, y2 "10"
|
|
] []
|
|
, Svg.text_ [ x (String.fromFloat xpix)
|
|
, style "text-anchor" "middle"
|
|
, style "vertical-align" "bottom"
|
|
, y "25" ]
|
|
[ Svg.text label ]
|
|
]
|
|
xticks = List.map xtick <| List.range 0 6
|
|
bg = rect
|
|
[ x "0"
|
|
, width portalWidth
|
|
, height graphHeight
|
|
, fill "#eef"
|
|
, stroke "none"
|
|
] []
|
|
markStart x =
|
|
let x1 = String.fromInt x
|
|
in Svg.path
|
|
[ S.d ("M " ++ x1 ++ " 40 " ++
|
|
"v -50 h 10 v 10 h -10 v -10")
|
|
, fill "#7c7"
|
|
, stroke "#4e4"
|
|
, H.id "left-marker"
|
|
, strokeWidth "3"
|
|
] []
|
|
markEnd x =
|
|
let x1 = String.fromInt x
|
|
in Svg.path
|
|
[ S.d ("M " ++ x1 ++ " 40 " ++
|
|
"v -50 h -10 v 10 h 10 v -10")
|
|
, fill "#c77"
|
|
, stroke "#e44"
|
|
, H.id "right-marker"
|
|
, strokeWidth "3"
|
|
] []
|
|
in
|
|
svg
|
|
[ width portalWidth
|
|
, height (graphHeight + 20)
|
|
, on "pointerdown" timeClickDecoder
|
|
, viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++
|
|
" " ++ (String.fromInt (graphHeight + 10)))
|
|
]
|
|
(bg::(markStart 22)::(markEnd 422)::xticks)
|
|
|
|
|
|
cadenceView : List Point -> Svg Msg
|
|
cadenceView =
|
|
measureView "cadence" "#44ee44" (.cadence >> Maybe.map toFloat)
|
|
|
|
powerView = measureView "power" "#994444" (.power >> Maybe.map toFloat)
|
|
|
|
eleView = measureView "elevation" "#4444ee" (.pos >> .ele)
|
|
|
|
|
|
trackView : Int -> Int -> ZoomLevel -> List Point -> Svg Msg
|
|
trackView leftedge topedge zoom points =
|
|
let plot p =
|
|
let (x, y) = pixelFromCoord (toCoord p.pos) zoom
|
|
x_ = x - leftedge
|
|
y_ = y - topedge
|
|
in (String.fromInt x_) ++ ", " ++
|
|
(String.fromInt y_) ++ ", "
|
|
line = String.concat (List.map plot points)
|
|
in
|
|
svg
|
|
[ H.style "width" "100%"
|
|
, H.style "height" "100%"
|
|
, H.style "position" "absolute"
|
|
]
|
|
[ g
|
|
[ fill "none"
|
|
, stroke "blue"
|
|
, strokeWidth "7"
|
|
, strokeOpacity "0.5"]
|
|
[
|
|
polyline
|
|
[ fill "none"
|
|
, S.points line
|
|
] []
|
|
]
|
|
]
|
|
|
|
|
|
px x = String.fromInt x ++ "px"
|
|
|
|
tiles xs ys zoom =
|
|
List.map
|
|
(\ y -> div []
|
|
(List.map (\ x -> tileImg zoom (TileNumber x y)) xs))
|
|
ys
|
|
|
|
ifTrack : Model -> (List Point -> Html msg) -> Html msg
|
|
ifTrack model content =
|
|
case model.track of
|
|
Present t ->
|
|
let (dt, _) = dragDelta Graph model.drag
|
|
dpix = dt * model.duration // portalWidth
|
|
start = toFloat (model.startTime + dpix)
|
|
points = Point.subseq t start (toFloat model.duration) |>
|
|
Point.downsample 300
|
|
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 =
|
|
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
|
|
(pixelCentreX,pixelCentreY) = pixelFromCoord centre zoom
|
|
leftedge = mintile.x * 256
|
|
topedge = mintile.y * 256
|
|
offsetX = pixelCentreX - (width // 2) - leftedge
|
|
offsetY = pixelCentreY - (height // 2) - topedge
|
|
pixWidth = (1 + maxtile.x - mintile.x) * 256
|
|
pixHeight = (1 + maxtile.y - mintile.y) * 256
|
|
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)
|
|
in div [style "position" "absolute"
|
|
,style "width" (px pixWidth)
|
|
,style "height" (px pixHeight)
|
|
,style "left" (px -offsetX)
|
|
,style "top" (px -offsetY)
|
|
,style "lineHeight" (px 0)
|
|
,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
|
|
|
|
withSwallowing m =
|
|
{ message = m
|
|
, stopPropagation = True
|
|
, preventDefault = True
|
|
}
|
|
|
|
-- FIXME should do something useful with deltaMode as well as deltaY
|
|
mapWheelDecoder =
|
|
let sgn x = floor((abs x)/x)
|
|
in D.map (withSwallowing << MapScale << sgn) (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 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"
|
|
, 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)
|
|
, style "display" "inline-block"
|
|
, style "position" "relative"
|
|
, style "overflow" "hidden"]
|
|
[canvasV]
|
|
, text ("Zoom level " ++ (String.fromInt (toZoom model.zoom)))
|
|
, span []
|
|
[ button [ onClick (MapScale -zoomStep) ] [ text "-" ]
|
|
, button [ onClick (MapScale zoomStep) ] [ text "+" ]
|
|
]
|
|
]
|
|
, div [ style "display" "flex"
|
|
, Html.Events.custom "wheel" timeWheelDecoder
|
|
, 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"
|
|
]
|
|
[ div [] [ ifTrack model cadenceView ]
|
|
, div [] [ ifTrack model powerView ]
|
|
, div [] [ ifTrack model eleView ]
|
|
, div [] [ ifTrack model timeAxis ]
|
|
]
|
|
]
|
|
|
|
view : Model -> Browser.Document Msg
|
|
view model =
|
|
Browser.Document "Souplesse elm" [ (viewDiv model) ]
|