dan/souplesse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: dan:ab3a5aaf9f4f0dcbfb748f018809f0a8f3ddf63b
Branches Tags
dan:main
..
compare: dan:e0d395ba9f2d8e2bedde9f604dea8d9d31c961fb
Branches Tags
dan:main

No commits in common. "ab3a5aaf9f4f0dcbfb748f018809f0a8f3ddf63b" and "e0d395ba9f2d8e2bedde9f604dea8d9d31c961fb" have entirely different histories.
ab3a5aaf9f ... e0d395ba9f

2 changed files with 70 additions and 139 deletions
Show Stats Expand all files Collapse all files

178
frontend/src/Main.elm
View File

@ -80,11 +80,11 @@ type alias Lng = Float
sec x = 1 / (cos x)
toCoord : Pos -> Coord
toCoord pos =
toCoord : Lat -> Lng -> Coord
toCoord lat lng =
let
lat_rad = pos.lat * pi / 180
x = (pos.lon + 180) / 360
lat_rad = lat * pi / 180
x = (lng + 180) / 360
y = (1 - (logBase e ((tan lat_rad) + (sec lat_rad))) / pi) / 2
in
Coord x y
@ -126,35 +126,27 @@ boundingTiles centre z width height =
-- MODEL
type DragTarget = Map | Graph | StartMark | EndMark
type Drag
= None
| Dragging DragTarget (Int, Int) (Int, Int)
| Dragging (Int, Int) (Int, Int)
dragTo : Drag -> (Int, Int) -> Drag
dragTo d dest =
case d of
None -> None
Dragging target from to -> Dragging target from dest
Dragging from to -> Dragging from dest
dragDelta target d =
dragDelta 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)
None -> (0,0)
Dragging (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
, timeDrag: Drag
, startTime : Int
, duration : Int
, track: TrackState }
@ -166,9 +158,7 @@ init _ url navKey =
Just (Timeline (Just s) (Just d)) -> (s, d)
_ -> (10,10)
in
((Model
(toCoord (Pos 0 0 Nothing))
(FineZoomLevel (1*8)) None 0 0 Empty),
((Model (toCoord 51.60 -0.01) (FineZoomLevel (13*8)) None None start duration Empty),
(fetchTrack start duration))
-- SUBSCRIPTIONS
@ -191,45 +181,37 @@ fetchTrack start duration = Http.get
type Msg
= MapScale Int
| DragStart DragTarget (Int, Int)
| Drag (Int, Int)
| DragFinish (Int, Int)
| MapDragStart (Int, Int)
| MapDrag (Int, Int)
| MapDragFinish (Int, Int)
| TimeScale (Float)
| TimeDragStart (Int, Int)
| TimeDrag (Int, Int)
| TimeDragFinish (Int, Int)
| Loaded (Result Http.Error (List Point))
| NewUrlRequest
| UrlChanged
| Dribble String
update : Msg -> Model -> (Model, Cmd Msg)
update msg model = (updateModel msg model, Cmd.none)
update msg model = (newModel msg model, Cmd.none)
updateModel msg model =
newModel 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) }
MapDragStart (x,y) ->
{ model | drag = Dragging (x,y) (x,y) }
Drag (x,y) ->
MapDrag (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
MapDragFinish (x,y) ->
{ model | drag = None,
centre = translatePixels model.centre (toZoom model.zoom) (dragDelta model.drag) }
TimeScale factor ->
let fudge = factor
len = model.duration - floor(fudge)
@ -238,26 +220,25 @@ updateModel 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 ->
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
}
Ok trk -> { model | track = Present trk }
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
@ -308,20 +289,23 @@ tileImg zoom tilenumber = img [ width 256,
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)
measureView title colour fn allPoints =
let filteredPoints = Point.downsample 300 allPoints
graphHeight = 180
startTime = case allPoints of
(p::_) -> p.time
_ -> 0
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)
maxY = List.foldr max 0 (List.filterMap fn filteredPoints)
minY = List.foldr min maxY (List.filterMap fn filteredPoints)
(minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY
rangeYaxis = maxYaxis - minYaxis
maxX = Point.duration points
string = String.concat (List.map coords points)
maxX = Point.duration allPoints
string = String.concat (List.map coords filteredPoints)
ttick = timeTick maxX
firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
ybar n = line
@ -408,13 +392,13 @@ measureView title colour fn points =
, 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
timeAxis allPoints =
let filteredPoints = Point.downsample 300 allPoints
graphHeight = 30
startTime = case allPoints of
(p::_) -> p.time
_ -> 0
maxX = Point.duration allPoints
ttick = timeTick maxX
firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime
xtick n =
@ -447,35 +431,13 @@ timeAxis points =
, 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)))
, height graphHeight
, preserveAspectRatio "none"
]
(bg::(markStart 22)::(markEnd 422)::xticks)
(bg::xticks)
cadenceView : List Point -> Svg Msg
@ -490,7 +452,7 @@ 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
let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) zoom
x_ = x - leftedge
y_ = y - topedge
in (String.fromInt x_) ++ ", " ++
@ -528,11 +490,10 @@ ifTrack : Model -> (List Point -> Html msg) -> Html msg
ifTrack model content =
case model.track of
Present t ->
let (dt, _) = dragDelta Graph model.drag
let (dt, _) = dragDelta model.timeDrag
dpix = dt * model.duration // portalWidth
start = toFloat (model.startTime + dpix)
points = Point.subseq t start (toFloat model.duration) |>
Point.downsample 300
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"]
@ -560,12 +521,11 @@ canvas centre zoom width height model =
,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)) ]
,Pointer.onUp (\e -> MapDragFinish (epos e))
,Pointer.onMove (\e -> MapDrag (epos e))
,Pointer.onDown (\e -> MapDragStart (epos e)) ]
(tv :: tiles xs ys zoom)
portalWidth = 600
portalHeight = 600
@ -585,7 +545,7 @@ timeWheelDecoder =
viewDiv : Model -> Html Msg
viewDiv model =
let coord = translate model.centre (pixelsToCoord (toZoom model.zoom) (dragDelta Map model.drag))
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"
@ -608,9 +568,9 @@ viewDiv model =
]
, 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))
, 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"
]

31
frontend/src/Point.elm
View File

@ -1,4 +1,4 @@
module Point exposing(Pos, Point, decoder, downsample, duration, subseq, startTime, centre)
module Point exposing(Pos, Point, decoder, downsample, duration, subseq)
import Json.Decode as D
@ -63,35 +63,6 @@ duration points =
(p::ps) -> (last p ps).time - p.time
_ -> 0
startTime points =
case points of
(p::ps) -> Just p.time
_ -> Nothing
type Bound = Bound Pos Pos | NoBound
extendBound : Pos -> Bound -> Bound
extendBound pos b =
let {lat, lon} = pos
in case b of
(Bound p1 p2) ->
Bound
(Pos (min lat p1.lat) (min lon p1.lon) Nothing)
(Pos (max lat p2.lat) (max lon p2.lon) Nothing)
NoBound ->
Bound pos pos
bounds points =
List.foldr extendBound NoBound (List.map .pos points)
centre points =
case bounds points of
Bound min max -> Pos
((max.lat + min.lat) / 2)
((max.lon + min.lon) / 2)
Nothing
NoBound -> Pos 0 0 Nothing
subseq points start dur =
case points of
[] -> []