Main.elm (19900B)
1 module Main exposing (view) 2 3 import Browser 4 import Browser.Navigation as Nav 5 import Html exposing (Html, button, div, span, text, img) 6 import Html.Attributes as H exposing (src, style, width, height) 7 import Html.Events exposing (onClick, on) 8 import Html.Events.Extra.Pointer as Pointer 9 import Maybe exposing (Maybe) 10 import Model exposing (..) 11 import Lib exposing(..) 12 import List.Extra exposing(find) 13 import Json.Decode as D 14 import Http 15 import Point exposing (Point, decoder) 16 import Pos exposing (Pos) 17 import Svg exposing (Svg, svg, rect, g, polyline, line, mask) 18 import Svg.Attributes as S exposing 19 ( viewBox 20 , preserveAspectRatio 21 , transform 22 , x, y 23 , x1, y1 , x2, y2 24 , fill 25 , stroke, strokeWidth, strokeOpacity) 26 import Time 27 import TileMap exposing (..) 28 import Url.Parser exposing (Parser, (<?>), int, map, s, string) 29 import Url.Parser.Query as Query 30 import Url exposing (Url) 31 32 type Route = Timeline (Maybe Int) (Maybe Int) 33 34 routeParser : Parser (Route -> a) a 35 routeParser = 36 map Timeline (s "timeline" <?> Query.int "start" <?> Query.int "duration") 37 38 39 -- MAIN 40 41 42 main = 43 Browser.application 44 { init = init 45 , update = update 46 , subscriptions = subscriptions 47 , onUrlRequest = \ _ -> NewUrlRequest 48 , onUrlChange = \ _ -> UrlChanged 49 , view = view } 50 51 -- MATHS 52 53 54 -- MODEL 55 56 57 subtractTuple (fx,fy) (tx,ty) = (fx-tx, fy-ty) 58 59 60 init : () -> Url -> Nav.Key -> (Model, Cmd Msg) 61 init _ url navKey = 62 let (start, duration) = 63 case Url.Parser.parse routeParser url of 64 Just (Timeline (Just s) (Just d)) -> (toFloat s, toFloat d) 65 _ -> (10,10) 66 in (Model.empty, fetchTrack start duration) 67 68 -- SUBSCRIPTIONS 69 70 subscriptions : Model -> Sub Msg 71 subscriptions model = Sub.none 72 73 74 fetchTrack start duration = Http.get 75 { url = ("http://localhost:3000/points?start=" ++ 76 String.fromInt (floor start) ++ 77 "&duration=" ++ 78 String.fromInt (ceiling duration)) 79 , expect = Http.expectJson Loaded (D.list Point.decoder) 80 } 81 82 83 84 -- UPDATE 85 86 type Msg 87 = MapScale Int 88 | DragStart DragState 89 | Drag (Int, Int) 90 | DragFinish (Int, Int) 91 | TimeScale (Float) 92 | Loaded (Result Http.Error (List Point)) 93 | NewUrlRequest 94 | UrlChanged 95 | Dribble String 96 97 98 update : Msg -> Model -> (Model, Cmd Msg) 99 100 update msg model = (updateModel msg model, Cmd.none) 101 102 secondsFromPixels model seconds = 103 (toFloat seconds) * model.duration / portalWidth 104 105 106 107 dragUpdate : Model -> (Int, Int) -> Model 108 dragUpdate model (newx, newy) = 109 case model.drag of 110 Nothing -> model 111 Just (DragMap fromxy fromcoord) -> 112 let t = subtractTuple fromxy (newx, newy) 113 in { model | centre = translate fromcoord (pixelsToCoord model.zoom t) } 114 Just (DragGraph (fromx,_) fromtime) -> 115 let time = secondsFromPixels model (fromx - newx) 116 startTime = fromtime + time 117 clampVisible = clamp startTime (startTime + model.duration) 118 in { model | 119 startTime = startTime 120 , leftMark = clampVisible model.leftMark 121 , rightMark = clampVisible model.rightMark 122 } 123 Just (DragLeftMark (fromx,_) fromtime) -> 124 let time = secondsFromPixels model (fromx - newx) 125 in { model | leftMark = fromtime - time 126 , rightMark = max (fromtime - time) model.rightMark } 127 Just (DragRightMark (fromx,_) fromtime) -> 128 let time = secondsFromPixels model (fromx - newx) 129 in { model | rightMark = max (fromtime - time) model.leftMark } 130 131 132 133 updateModel msg model = 134 case msg of 135 MapScale y -> 136 { model | zoom = incZoom model.zoom y } 137 138 DragStart state -> 139 { model | drag = Just state } 140 141 Drag (x,y) -> 142 dragUpdate model (x, y) 143 144 DragFinish (x,y) -> 145 let m = dragUpdate model (x, y) 146 in { m | drag = Nothing } 147 148 TimeScale factor -> 149 let startTime = model.startTime + factor / 2 150 duration = model.duration - factor 151 clampVisible = clamp startTime (startTime + duration) 152 in { model | 153 startTime = startTime 154 , duration = duration 155 , leftMark = clampVisible model.leftMark 156 , rightMark = clampVisible model.rightMark 157 } 158 159 Loaded result -> 160 case result of 161 Ok trk -> 162 let start = Maybe.withDefault 0 (Point.startTime trk) 163 duration = Point.duration trk 164 in 165 { model 166 | track = Present trk 167 , centre = toCoord (Point.centre trk) 168 , zoom = ZoomLevel (13 * 8) 169 , startTime = start 170 , duration = duration 171 , leftMark = start 172 , rightMark = start + duration 173 } 174 Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") } 175 Err e -> { model | track = Debug.log "unknown error" (Failure "e") } 176 NewUrlRequest -> model 177 UrlChanged -> model 178 Dribble message -> 179 let _ = Debug.log "dribble" message 180 in model 181 182 183 -- VIEW 184 185 formatTime epoch = 186 let utc = Time.utc 187 time = Time.millisToPosix <| floor(epoch * 1000) 188 zeroed i = String.padLeft 2 '0' (String.fromInt i) 189 in String.fromInt (Time.toHour utc time) 190 ++ ":" ++ 191 zeroed (Time.toMinute utc time) 192 ++ ":" ++ 193 zeroed (Time.toSecond utc time) 194 195 timeTick duration = 196 let width = duration / 6 197 candidates = 198 [ 1 199 , 3 200 , 5 201 , 10 202 , 15 203 , 30 204 , 60 205 , 60 * 3 206 , 60 * 5 207 , 60 * 10 208 , 60 * 15 209 , 60 * 30 210 , 60 * 60 211 ] 212 in case List.Extra.find (\ candidate -> width <= candidate) candidates of 213 Just n -> n 214 Nothing -> width 215 216 type alias Colour = String 217 218 selectionRect selection = 219 case selection of 220 Nothing -> g [] [] 221 Just (left, right) -> 222 rect [ fill "#fdd" 223 , S.x (String.fromInt left) 224 , S.y "0" 225 , width (right - left) 226 , S.height "100%" 227 ] [] 228 229 thresholdMask id maxX minY threshold maxY = 230 let r y0 y1 colour = 231 rect 232 [ 233 x "0" 234 , y (String.fromFloat y0) 235 , width (ceiling maxX) 236 , height (floor (y1 - y0)) 237 , fill colour 238 ] [] 239 in 240 mask 241 [ S.id id ] 242 [ r minY threshold "black" 243 , r threshold maxY "white" 244 ] 245 246 measureView : String -> Colour -> (Point -> Maybe Float) -> Float -> Maybe (Float, Float) -> List Point -> Svg Msg 247 measureView title colour fn threshold selection points = 248 let graphHeight = 180 249 startTime = Maybe.withDefault 0 (Point.startTime points) 250 coords p = case (fn p) of 251 Just c -> 252 (String.fromFloat (p.time - startTime)) ++ "," ++ 253 (String.fromFloat c) ++ ", " 254 Nothing -> "" 255 maxY = List.foldr max 0 (List.filterMap fn points) 256 minY = List.foldr min maxY (List.filterMap fn points) 257 (minYaxis, maxYaxis, tickY) = looseLabels 4 minY maxY 258 rangeYaxis = maxYaxis - minYaxis 259 maxX = Point.duration points 260 string = String.concat (List.map coords points) 261 ttick = timeTick maxX 262 firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime 263 scaledMarks = Maybe.map 264 (\(s, e) -> 265 (floor((s - startTime) * portalWidth/maxX), 266 floor((e - startTime) * portalWidth/maxX))) 267 selection 268 ybar n = line 269 [ fill "none" 270 , style "vector-effect" "non-scaling-stroke" 271 , strokeWidth "1" 272 , stroke "#aaa" 273 , x1 "0" 274 , y1 (String.fromFloat (minYaxis + n * tickY)) 275 , x2 (String.fromFloat (0.95 * maxX)) 276 , y2 (String.fromFloat (minYaxis + n * tickY)) 277 ] [] 278 xtick n = 279 let t = firstTimeTick + n * timeTick maxX 280 xpix = t * portalWidth/maxX 281 label = formatTime (t + startTime) 282 in 283 g [] 284 [ line 285 [ fill "none" 286 , style "vector-effect" "non-scaling-stroke" 287 , strokeWidth "1" 288 , stroke "#aaa" 289 , x1 (String.fromFloat xpix) 290 , y1 "0" 291 , x2 (String.fromFloat xpix) 292 , y2 "180" 293 ] [] 294 ] 295 296 ylabel n = Svg.text_ 297 [ x "99%", y (String.fromFloat (graphHeight - graphHeight * n * (tickY/rangeYaxis))) 298 , style "text-anchor" "end" 299 , style "fill" "#222244" 300 ] [ Svg.text (String.fromFloat (minYaxis + n * tickY)) ] 301 302 in 303 svg 304 [ width portalWidth 305 , height graphHeight 306 , preserveAspectRatio "none" 307 ] 308 [ rect 309 [ x "0" 310 , width portalWidth 311 , height graphHeight 312 , fill "#f8f8ff" 313 , stroke "none" 314 ] [] 315 , selectionRect scaledMarks 316 , g 317 [ stroke colour 318 , strokeWidth "2" 319 , transform ( "scale(" ++ (String.fromFloat (portalWidth / maxX)) ++ 320 ", " ++ (String.fromFloat (graphHeight / rangeYaxis)) ++")" ++ 321 "translate(0, " ++ (String.fromFloat maxYaxis) ++") scale(1, -1)") 322 ] 323 [ ybar 0 324 , ybar 1 325 , ybar 2 326 , ybar 3 327 , polyline 328 [ fill colour 329 , style "opacity" "30%" 330 , S.mask ("url(#" ++ title ++ "-mask)") 331 , stroke "none" 332 , style "vector-effect" "non-scaling-stroke" 333 , S.points (string ++ 334 (String.fromFloat maxX) ++ ",0, 0,0") 335 ] [] 336 , thresholdMask (title ++ "-mask") maxX minY threshold maxY 337 , polyline 338 [ fill "none" 339 , style "vector-effect" "non-scaling-stroke" 340 , S.points string 341 ] [] 342 ] 343 , Svg.text_ 344 [ x "99%", y "12%" 345 , style "fill" "#222244" 346 , style "text-anchor" "end" 347 , style "font-weight" "bold" 348 , style "text-shadow" "2px 2px 1px #dddddd" 349 ] [ Svg.text title 350 ] 351 , ylabel 0 352 , ylabel 1 353 , ylabel 2 354 , ylabel 3 355 , xtick 0 356 , xtick 1 357 , xtick 2 358 , xtick 3 359 , xtick 4 360 , xtick 5 361 ] 362 363 type alias TargetedPointerEvent = 364 { pointerEvent : Pointer.Event 365 , targetId : String 366 } 367 368 targetedEventDecoder = 369 D.map2 TargetedPointerEvent 370 Pointer.eventDecoder 371 (D.at ["target", "id"] D.string) 372 373 onDownWithTarget tag = 374 let 375 decoder = 376 targetedEventDecoder 377 |> D.map tag 378 |> D.map options 379 380 options message = 381 { message = message 382 , stopPropagation = True 383 , preventDefault = True 384 } 385 in 386 Html.Events.custom "pointerdown" decoder 387 388 handleDragMark model e = 389 let epos ev = Tuple.mapBoth floor floor ev.pointer.clientPos 390 in case e.targetId of 391 "left-marker" -> 392 DragStart (DragLeftMark (epos e.pointerEvent) model.leftMark) 393 "right-marker" -> 394 DragStart (DragRightMark (epos e.pointerEvent) model.rightMark) 395 _ -> Dribble "drag with unknown target" 396 397 398 timeAxis model selection points = 399 let graphHeight = 30 400 startTime = Maybe.withDefault 0 (Point.startTime points) 401 maxX = Point.duration points 402 ttick = timeTick maxX 403 firstTimeTick = (toFloat (floor(startTime / ttick))) * ttick - startTime 404 xtick n = 405 let t = firstTimeTick + (toFloat n) * timeTick maxX 406 xpix = t * portalWidth/maxX 407 label = formatTime (t + startTime) 408 in 409 g [] 410 [ line 411 [ fill "none" 412 , style "vector-effect" "non-scaling-stroke" 413 , strokeWidth "1" 414 , stroke "#333" 415 , x1 (String.fromFloat xpix) 416 , y1 "0" 417 , x2 (String.fromFloat xpix) 418 , y2 "10" 419 ] [] 420 , Svg.text_ [ x (String.fromFloat xpix) 421 , style "text-anchor" "middle" 422 , style "vertical-align" "bottom" 423 , y "25" ] 424 [ Svg.text label ] 425 ] 426 xticks = List.map xtick <| List.range 0 6 427 bg = rect 428 [ x "0" 429 , width portalWidth 430 , height graphHeight 431 , fill "#eef" 432 , stroke "none" 433 ] [] 434 markStart x = 435 let x1 = String.fromInt x 436 in Svg.path 437 [ S.d ("M " ++ x1 ++ " 40 " ++ 438 "v -50 h 10 v 10 h -10 v -10") 439 , fill "#7c7" 440 , stroke "#4e4" 441 , H.id "left-marker" 442 , strokeWidth "3" 443 ] [] 444 markEnd x = 445 let x1 = String.fromInt x 446 in Svg.path 447 [ S.d ("M " ++ x1 ++ " 40 " ++ 448 "v -50 h -10 v 10 h 10 v -10") 449 , fill "#c77" 450 , stroke "#e44" 451 , H.id "right-marker" 452 , strokeWidth "3" 453 ] [] 454 markStartPix = 455 floor ((model.leftMark - startTime) * portalWidth/maxX) 456 markEndPix = 457 ceiling ((model.rightMark - startTime) * portalWidth/maxX) 458 in 459 svg 460 [ width portalWidth 461 , height (graphHeight + 20) 462 , onDownWithTarget (handleDragMark model) 463 , viewBox ("0 -10 " ++ (String.fromInt portalWidth) ++ 464 " " ++ (String.fromInt (graphHeight + 10))) 465 ] 466 [ bg 467 , (markStart markStartPix) 468 , (markEnd markEndPix) 469 , g [] xticks 470 ] 471 472 473 trackView : Int -> Int -> ZoomLevel -> Maybe (Float, Float) -> List Point -> Svg Msg 474 trackView leftedge topedge zoom selection points = 475 let plot p = 476 let (x, y) = pixelFromCoord (toCoord p.pos) zoom 477 x_ = x - leftedge 478 y_ = y - topedge 479 in (String.fromInt x_) ++ ", " ++ 480 (String.fromInt y_) ++ ", " 481 line = String.concat (List.map plot points) 482 selectedPoints = 483 Maybe.map 484 (\(s, e) -> 485 List.filter (\p -> p.time >= s && p.time <= e) points) 486 selection 487 selectionLine = 488 case selectedPoints of 489 Just spoints -> 490 polyline [ S.points (String.concat (List.map plot spoints)) ] [] 491 Nothing -> g [] [] 492 493 in 494 svg 495 [ H.style "width" "100%" 496 , H.style "height" "100%" 497 , H.style "position" "absolute" 498 ] 499 [ g 500 [ fill "none" 501 , stroke "blue" 502 , strokeWidth "5" 503 , strokeOpacity "0.5"] 504 [ 505 polyline 506 [ fill "none" 507 , S.points line 508 ] [] 509 , g [ stroke "red", strokeWidth "7", strokeOpacity "0.9" ] 510 [ selectionLine ] 511 ] 512 ] 513 514 515 px x = String.fromInt x ++ "px" 516 517 ifTrack : Model -> ( Maybe (Float, Float) -> List Point -> Html msg) -> Html msg 518 ifTrack model content = 519 case model.track of 520 Present t -> 521 let start = model.startTime 522 points = Point.subseq t start model.duration |> 523 Point.downsample 300 524 in content (Model.marks model) points 525 Failure f -> Debug.log f (div [] [ Html.text "failure", Html.text f]) 526 Loading -> div [] [Html.text "loading"] 527 Empty -> div [] [Html.text "no points"] 528 529 canvas : Coord -> ZoomLevel -> Int -> Int -> Model -> Html Msg 530 canvas centre zoom width height model = 531 let tm = TileMap centre zoom width height 532 mapBounds = TileMap.bounds tm 533 (pixelCentreX, pixelCentreY) = pixelFromCoord centre zoom 534 offsetX = pixelCentreX - (width // 2) - mapBounds.left 535 offsetY = pixelCentreY - (height // 2) - mapBounds.top 536 epos e = Tuple.mapBoth floor floor e.pointer.clientPos 537 tv = ifTrack model (trackView mapBounds.left mapBounds.top zoom) 538 in div [style "position" "absolute" 539 ,style "width" (px mapBounds.width) 540 ,style "height" (px mapBounds.height) 541 ,style "left" (px -offsetX) 542 ,style "top" (px -offsetY) 543 ,style "lineHeight" (px 0) 544 ,Pointer.onUp (\e -> DragFinish (epos e)) 545 ,Pointer.onMove (\e -> Drag (epos e)) 546 ,Pointer.onDown (\e -> DragStart (DragMap (epos e) model.centre))] 547 (tv :: tiles tm) 548 549 550 portalWidth = 600 551 portalHeight = 600 552 553 withSwallowing m = 554 { message = m 555 , stopPropagation = True 556 , preventDefault = True 557 } 558 559 -- FIXME should do something useful with deltaMode as well as deltaY 560 mapWheelDecoder = 561 let sgn x = floor((abs x)/x) 562 in D.map (withSwallowing << MapScale << sgn) (D.field "deltaY" D.float) 563 564 timeWheelDecoder = 565 D.map (withSwallowing << TimeScale) (D.field "deltaY" D.float) 566 567 viewDiv : Model -> Html Msg 568 viewDiv model = 569 let canvasV = canvas model.centre model.zoom portalWidth portalHeight model 570 epos e = Tuple.mapBoth floor floor e.pointer.clientPos 571 in div [ style "display" "flex" 572 , style "column-gap" "15px" 573 ] 574 [ div [ style "display" "flex" 575 , Html.Events.custom "wheel" mapWheelDecoder 576 , style "flex-direction" "column"] 577 [ div [ style "width" (px portalWidth) 578 , style "height" (px portalHeight) 579 , style "display" "inline-block" 580 , style "position" "relative" 581 , style "overflow" "hidden"] 582 [canvasV] 583 , span [] 584 [ button [ onClick (MapScale -zoomStep) ] [ text "-" ] 585 , button [ onClick (MapScale zoomStep) ] [ text "+" ] 586 ] 587 ] 588 , div [ style "display" "flex" 589 , Html.Events.custom "wheel" timeWheelDecoder 590 , Pointer.onUp (\e -> DragFinish (epos e)) 591 , Pointer.onMove (\e -> Drag (epos e)) 592 , Pointer.onDown (\e -> DragStart (DragGraph (epos e) model.startTime)) 593 , style "flex-direction" "column" 594 , style "row-gap" "10px" 595 ] 596 [ div [] 597 (List.map (\g -> 598 div [] 599 [ ifTrack model 600 <| measureView g.id g.colour g.extractor g.threshold 601 ] 602 ) 603 model.graphs) 604 , div [] [ ifTrack model (timeAxis model) ] 605 ] 606 ] 607 608 view : Model -> Browser.Document Msg 609 view model = 610 Browser.Document "Souplesse" [ (viewDiv model) ]