main.fnl (18541B)
1 ; (local { : view } (require :fennel)) 2 (local { : fdopen } (require :posix.stdio)) 3 (local ptime (require :posix.time)) 4 (local cqueues (require :cqueues)) 5 (local socket (require :cqueues.socket)) 6 7 (local nmea (require :nmea)) 8 (local tiles (require :tiles)) 9 10 (import-macros { : define-tests : expect : expect= } :assert) 11 12 (local profile 13 (and (os.getenv "IN_NIX_SHELL") 14 (require :libluaperf))) 15 16 (macro with-timing [label & body] 17 `(let [before# (ptime.clock_gettime ptime.CLOCK_PROCESS_CPUTIME_ID) 18 ret# (table.pack (do ,body))] 19 (let [after# (ptime.clock_gettime ptime.CLOCK_PROCESS_CPUTIME_ID)] 20 (print ,label (.. (- after#.tv_sec before#.tv_sec) "s " 21 (// (- after#.tv_nsec before#.tv_nsec) 1000) "us ")) 22 (table.unpack ret#)))) 23 24 ; (with-timing :loop (for [i 1 100] (print i))) 25 26 27 (local { 28 : Gtk 29 : Gdk 30 : Gio 31 : GLib 32 : cairo 33 } 34 (require :lgi)) 35 36 (local CSS " 37 label.readout { 38 font: 48px \"Noto Sans\"; 39 margin: 10px; 40 padding: 5px; 41 background-color: rgba(0, 0, 0, 0.2); 42 } 43 ") 44 45 (local utc-offset 46 (let [now (os.time) 47 localt (os.date "*t" now) 48 utct (os.date "!*t" now)] 49 (tset localt :isdst false) 50 (os.difftime (os.time localt) (os.time utct)))) 51 52 53 (var viewport-width nil) 54 (var viewport-height nil) 55 (local tile-size 256) 56 57 (fn styles [] 58 (let [style_provider (Gtk.CssProvider)] 59 (Gtk.StyleContext.add_provider_for_screen 60 (Gdk.Screen.get_default) 61 style_provider 62 Gtk.STYLE_PROVIDER_PRIORITY_APPLICATION 63 ) 64 (style_provider:load_from_data CSS))) 65 66 (fn main-quit [] 67 (when profile (profile:stop)) 68 (Gtk.main_quit)) 69 70 (local window (Gtk.Window { 71 :title "Map" 72 :name "toplevel" 73 ;; cage will launch the window maximised, 74 ;; so these can be any value smaller than 75 ;; the max size 76 :default_width (case (os.getenv "MAPS_WIDTH") x (tonumber x) nil 100) 77 :default_height (case (os.getenv "MAPS_HEIGHT") x (tonumber x) nil 100) 78 :on_destroy main-quit 79 :on_size_allocate 80 (fn [w] 81 (let [(width height) (w:get_size)] 82 (set viewport-width width) 83 (set viewport-height height))) 84 })) 85 86 (local state-widgets { }) 87 88 (local { : view } (require :fennel)) 89 (local gpx (require :gpx)) 90 91 (fn tile-xy-for-track [trackpoints zoom] 92 (icollect [_ { : lat : lon} (ipairs trackpoints)] 93 (let [(x y) (tiles.latlon->tile lat lon zoom)] 94 [x y]))) 95 96 (local 97 app-state { 98 :time-of-day 0 99 :elapsed-time 0 100 :speed nil 101 :lat 49 102 :lon 0 103 :zoom 17 104 :course 0 ; direction of travel 105 :orientation 0 ; map rotation angle from north 106 :rotation-speed 0 107 :tiles {} 108 :tracks [ 109 (gpx.get_trackpoints_only "track.gpx") 110 ] 111 } 112 ) 113 114 (fn merge [table1 table2] 115 (collect [k v (pairs table2) &into table1] 116 k v)) 117 118 119 120 (fn map-bounds-tile [tile-x tile-y] 121 ;; we fetch enough tiles around the current location that the screen 122 ;; can be freely rotated without needing to fetch more. 123 124 ;; when facing north, we have e.g. 125 ;; 720 width is 2.8 * 256 pixel tiles 126 ;; 800 height is 3.125 tiles 127 ;; 128 ;; however: 129 ;; - when the map is rotated 90 degrees we instead have 130 ;; 3.125 tiles horizontally and 2.8 vertically 131 ;; - at e.g a 45 degree angle ... something else? 132 ;; 133 ;; the furthest points visible from the centre of the screen are the 134 ;; corners. So, we draw a circle about the centre which goes 135 ;; through those points. To ensure we have enough tiles to fill the 136 ;; screen at any angle, we fetch every tile that's (partly 137 ;; or entirely) inside that circle 138 139 (let [radius (/ (math.sqrt (+ (^ viewport-width 2) (^ viewport-height 2))) 140 tile-size 2) 141 min-tile-x (math.floor (- tile-x radius)) 142 max-tile-x (math.floor (+ tile-x radius)) 143 min-tile-y (math.floor (- tile-y radius)) 144 max-tile-y (math.floor (+ tile-y radius)) 145 num-tiles-x (+ 1 (- max-tile-x min-tile-x)) 146 num-tiles-y (+ 1 (- max-tile-y min-tile-y))] 147 { 148 :min { :x min-tile-x :y min-tile-y } 149 :max { :x max-tile-x :y max-tile-y } 150 : num-tiles-x 151 : num-tiles-y 152 :pixels { 153 :x (* tile-size num-tiles-x) 154 :y (* tile-size num-tiles-y) 155 } 156 :centre { 157 :x (/ (+ min-tile-x max-tile-x 1) 2) 158 :y (/ (+ min-tile-y max-tile-y 1) 2) 159 } 160 :to-pixels (fn [tile-x tile-y] 161 (values (* tile-size (- tile-x min-tile-x)) 162 (* tile-size (- tile-y min-tile-y)))) 163 164 })) 165 166 (define-tests 167 :map-bounds-tile 168 ;; diagonal radius is 538 pixels, 2.1 tiles 169 170 (let [bounds (map-bounds-tile 65539.5 45014.5)] 171 (expect= bounds.min {:x 65537 :y 45012}) 172 (expect= bounds.max {:x 65541 :y 45016}) 173 (expect= bounds.centre {:x 65539.5 :y 45014.5})) 174 175 (let [bounds (map-bounds-tile 65539.0 45014.0)] 176 (expect= bounds.min {:x 65536 :y 45011}) 177 (expect= bounds.max {:x 65541 :y 45016}) 178 (expect= bounds.centre {:x 65539 :y 45014}) 179 )) 180 181 (fn map-bounds [lat lon zoom] 182 (let [(tile-x tile-y) (tiles.latlon->tile lat lon zoom)] 183 (map-bounds-tile tile-x tile-y))) 184 185 (fn bounds= [a b] 186 (and (= a.min.x b.min.x) 187 (= a.min.y b.min.y) 188 (= a.max.x b.max.x) 189 (= a.max.y b.max.y))) 190 191 (local cq (cqueues.new)) 192 193 (fn road-width-for [line] 194 (case (?. line :tags :highway) 195 :motorway 18 196 :trunk 17 197 :primary 16 198 :secondary 14 199 :cycleway 4 200 :footway 4 201 other 12)) 202 203 (fn cairo-road-path [g [[sx sy] & points] bounds] 204 (let [min bounds.min 205 { : line_to } g] 206 (g:move_to (bounds.to-pixels sx sy)) 207 (each [_ [x y] (ipairs points)] 208 (line_to g (bounds.to-pixels x y))))) 209 210 (fn cairo-roads [g lines bounds] 211 (g:set_source_rgb 0 0 0) 212 (each [_ line (pairs lines)] 213 (g:set_line_width (road-width-for line)) 214 (cairo-road-path g line.points bounds ) 215 (g:stroke)) 216 (g:set_source_rgb 1 1 1) 217 (each [_ line (pairs lines)] 218 (g:set_line_width (- (road-width-for line) 2)) 219 (cairo-road-path g line.points bounds) 220 (g:stroke))) 221 222 (fn cairo-tracks [g tracks bounds] 223 (g:set_source_rgba 0.8 0 0 0.5) 224 (each [_ track (pairs tracks)] 225 (g:set_line_width 10) 226 (let [xypoints (tile-xy-for-track track app-state.zoom) 227 [sx sy] (. xypoints 1) 228 { : line_to } g] 229 (g:move_to (bounds.to-pixels sx sy)) 230 (each [_ [x y] (ipairs xypoints)] 231 (line_to g (bounds.to-pixels x y)))) 232 (g:stroke))) 233 234 235 (var map-surface nil) 236 237 (fn fetch-tiles [bounds tbl zoom] 238 (for [x bounds.min.x bounds.max.x] 239 (for [y bounds.min.y bounds.max.y] 240 (let [k (tiles.name x y zoom)] 241 (when (not (. tbl k)) 242 (tiles.fetch cq x y zoom #(tset tbl k $1))))))) 243 244 ;; iso 9899:1999 says 245 ;; "The atan2 functions return arctan y/x in the interval [−π , +π ] radians" 246 247 (fn clamp-angle [rad] 248 (let [circle (* 2 math.pi)] 249 (if 250 (< rad (- math.pi)) (clamp-angle (+ rad circle)) 251 (> rad math.pi) (clamp-angle (- rad circle)) 252 rad))) 253 254 (define-tests :clamp-angle 255 (expect= (clamp-angle 2) 2) 256 (expect= (clamp-angle (+ (* 4 math.pi) 2)) 2) 257 (expect= (clamp-angle (- 2 (* 4 math.pi))) 2)) 258 259 (fn deg->rad [deg] 260 (* math.pi (/ deg 180))) 261 262 (fn draw-onto-map-surface [surface bounds zoom] 263 (let [{ : num-tiles-x : num-tiles-y } bounds 264 road-width 14 265 tracks app-state.tracks 266 lines []] 267 268 (for [x bounds.min.x bounds.max.x] 269 (for [y bounds.min.y bounds.max.y] 270 (merge lines (or (. app-state.tiles (tiles.name x y zoom)) {})))) 271 272 (let [seen-road-names {} 273 g (cairo.Context.create surface)] 274 275 (g:set_source_rgb 0.7 0.8 0.8) 276 (g:rectangle 0 0 bounds.pixels.x bounds.pixels.y) 277 (g:fill) 278 279 (g:translate (+ (// bounds.pixels.x 2)) (+ (// bounds.pixels.y 2))) 280 (g:rotate (deg->rad (- app-state.course))) 281 (g:translate (- (// bounds.pixels.x 2)) (- (// bounds.pixels.y 2))) 282 283 (cairo-roads g lines bounds) 284 (cairo-tracks g tracks bounds) 285 286 (g:set_source_rgb 0.2 0.2 0.2) 287 (g:set_font_size (+ road-width 1)) 288 289 (each [_ line (pairs lines)] 290 (case line.name 291 n (let [[tx ty angle] line.label-place 292 ext (g:text_extents n) 293 w ext.width 294 h ext.height] 295 (when (and tx ty (not (. seen-road-names n))) 296 (let [(x y) (bounds.to-pixels tx ty)] 297 (tset seen-road-names n true) 298 299 (g:save) 300 (g:move_to x y) 301 302 (let [theta (clamp-angle 303 (- angle (deg->rad app-state.course)))] 304 (if (and (> theta 0) (< theta math.pi)) 305 (g:rotate (- angle (/ math.pi 2))) 306 (g:rotate (- angle (* math.pi 1.5))))) 307 308 (g:rel_move_to (- (// w 2)) 3) 309 (g:text_path n) 310 (g:fill) 311 (g:restore)))))) 312 313 surface))) 314 315 316 (fn on-osm-draw [widget g] 317 (let [(tile-x tile-y) (tiles.latlon->tile app-state.lat app-state.lon app-state.zoom) 318 bounds (map-bounds-tile tile-x tile-y) 319 offset-x (/ (- viewport-width bounds.pixels.x) 2) 320 offset-y (/ (- viewport-height bounds.pixels.y) 2) 321 x-to-centre (- tile-x bounds.centre.x) 322 y-to-centre (- tile-y bounds.centre.y) 323 angle (- (/ (* math.pi app-state.course) 180)) 324 x-to-centre-rot (- (* x-to-centre (math.cos angle)) 325 (* y-to-centre (math.sin angle))) 326 y-to-centre-rot (+ (* x-to-centre (math.sin angle)) 327 (* y-to-centre (math.cos angle))) 328 ] 329 330 (when (not map-surface) 331 (let [window (widget:get_window)] 332 (set map-surface 333 (doto 334 (window:create_similar_surface 335 cairo.Content.COLOR 336 bounds.pixels.x 337 bounds.pixels.y) 338 (draw-onto-map-surface bounds app-state.zoom))))) 339 340 341 (when (not (= app-state.orientation app-state.course)) 342 (g:translate (+ (/ viewport-width 2)) (+ (/ viewport-height 2))) 343 (g:rotate (* (/ (- 360 (- app-state.orientation app-state.course)) 180) math.pi)) 344 (g:translate (- (/ viewport-width 2)) (- (/ viewport-height 2)))) 345 346 (g:set_source_surface map-surface 347 (- offset-x (* tile-size x-to-centre-rot)) 348 (- offset-y (* tile-size y-to-centre-rot))) 349 (g:set_operator cairo.Operator.SOURCE) 350 (g:paint))) 351 352 353 354 (fn register-widget [name widget] 355 (tset state-widgets name widget) 356 widget) 357 358 (fn osm-widget [] 359 (register-widget 360 :osm 361 (Gtk.DrawingArea { 362 :width viewport-width :height viewport-height 363 :on_draw on-osm-draw 364 }))) 365 366 (fn readout [name text] 367 (register-widget 368 name 369 (doto (Gtk.Label {:label text : name}) 370 (-> (: :get_style_context) 371 (: :add_class :readout))))) 372 373 (local knot-in-m-s 374 (/ 1852 ; metres in nautical mile 375 3600 ; seconds in an hour 376 )) 377 378 (fn hhmmss [seconds-since-midnight] 379 (let [s (% seconds-since-midnight 60) 380 m (% (// (- seconds-since-midnight s) 60) 60) 381 h (// (- seconds-since-midnight (* m 60) s) 3600)] 382 (string.format "%d:%02d:%02d" h m s))) 383 384 (define-tests 385 :hhmmss 386 (expect= (hhmmss (+ 45 (* 60 12) (* 60 60 3))) "3:12:45")) 387 388 (fn turn-smoothly [from to] 389 (if (< (math.abs (- from to)) 3) to 390 (+ from (* 0.3 (- to from))))) 391 392 (fn update-app-state [new-vals] 393 (let [old-state (merge {} app-state) 394 old-bounds 395 (map-bounds app-state.lat app-state.lon app-state.zoom)] 396 (merge app-state new-vals) 397 (let [bounds 398 (map-bounds app-state.lat app-state.lon app-state.zoom)] 399 (when (not (bounds= old-bounds bounds)) 400 (fetch-tiles bounds app-state.tiles app-state.zoom) 401 (set map-surface nil))) 402 403 (when (not (= old-state.course app-state.course)) 404 (set map-surface nil)) 405 406 (when (or (not (= app-state.rotation-speed 0)) 407 (not (< -10 (- app-state.course app-state.orientation) 10))) 408 (let [distance (- app-state.course app-state.orientation) 409 direction (if (> distance 0) 1 -1) 410 abs-distance (* direction distance) 411 max-accel 0.2 412 max-speed (* 0.9 (math.sqrt (* 2 max-accel abs-distance)))] 413 (if (> (math.abs app-state.rotation-speed) max-speed) 414 (set app-state.rotation-speed (* direction max-speed)) 415 (set app-state.rotation-speed 416 (let [a 417 (+ app-state.rotation-speed 418 (* direction 419 (math.min 420 max-accel 421 (- max-speed (math.abs app-state.rotation-speed)))))] 422 (if (< -0.2 a 0.2) 0 a)))))) 423 424 (set app-state.orientation (+ app-state.orientation 425 app-state.rotation-speed)) 426 427 (each [name widget (pairs state-widgets)] 428 (case name 429 :speed (widget:set_label 430 (case app-state.speed 431 s (string.format "%.1f km/h" (* s 3.6)) 432 nil "---")) 433 :osm 434 (when (not (and ; false 435 (= old-state.lat app-state.lat) 436 (= old-state.lon app-state.lon) 437 (= old-state.orientation-actual 438 app-state.orientation) 439 )) 440 (: (widget:get_window) :invalidate_rect nil)) 441 :arrow (: (widget:get_window) :invalidate_rect nil) 442 :rose (: (widget:get_window) :invalidate_rect nil) 443 :time (widget:set_label 444 (hhmmss (+ utc-offset app-state.time-of-day))) 445 )))) 446 447 448 (fn readouts [] 449 (doto (Gtk.Box 450 { 451 :orientation Gtk.Orientation.VERTICAL 452 :halign Gtk.Align.END 453 }) 454 (-> (: :get_style_context) (: :add_class :readouts)) 455 (: :add (readout :time "")) 456 (: :add (readout :elapsed-time "")) 457 (: :add (readout :speed "0")))) 458 459 (fn arrow [] 460 (let [height 40] 461 (register-widget 462 :arrow 463 (Gtk.Label { 464 :halign Gtk.Align.CENTER 465 :valign Gtk.Align.CENTER 466 :width height :height height 467 :on_draw 468 (fn [self g] 469 (g:set_source_rgb 0.4 0.0 0.1) 470 (g:translate (// height 2) (// height 2)) 471 (g:rotate (* (/ (- app-state.course app-state.orientation) 472 180) math.pi)) 473 (g:translate (// height -2) (// height -2)) 474 (g:set_line_width 4) 475 (g:move_to 10 height) 476 (g:line_to (// height 2) 0) 477 (g:line_to (- height 10) height) 478 (g:fill) 479 true) 480 })))) 481 482 (fn deg->rad [degrees] 483 (* math.pi (/ degrees 180))) 484 485 (fn rose [] 486 (let [height 60] 487 (register-widget 488 :rose 489 (Gtk.Label { 490 :halign Gtk.Align.START 491 :valign Gtk.Align.START 492 :width height :height height 493 :on_draw 494 (fn [self g] 495 (g:save) 496 (g:set_line_width 1) 497 (g:set_source_rgb 0.4 0.0 0.1) 498 (g:arc (// height 2) (// height 2) 15 499 0 (* 2 math.pi)) 500 (g:stroke) 501 502 (g:translate (// height 2) (// height 2)) 503 (g:rotate (- (deg->rad app-state.orientation))) 504 (g:translate (// height -2) (// height -2)) 505 506 (g:set_line_width 2) 507 (g:move_to (// height 2) height) 508 (g:line_to (// height 2) 0) 509 510 (g:move_to 10 20) 511 (g:line_to (// height 2) 0) 512 (g:line_to (- height 10) 20) 513 (g:stroke) 514 515 (g:set_source_rgb 1 1 0) 516 (g:move_to (// height -2) (// height -2)) 517 (g:text_path "N") 518 (g:fill) 519 520 (g:restore) 521 true) 522 })))) 523 524 (fn read-gnss-sentence [l] 525 (if (not (= l "")) 526 (let [message (nmea.parse l)] 527 (case message 528 { : lat : lon : utc} 529 (update-app-state 530 { 531 : lat : lon 532 :time-of-day 533 (let [(h m s) (string.match utc "(..)(..)(..)")] 534 (+ s (* m 60) (* h 60 60))) 535 } 536 ) 537 { : speed-knots } 538 (update-app-state { :speed (* speed-knots knot-in-m-s) })) 539 (when message.bearing-true 540 (update-app-state { :course message.bearing-true }))))) 541 542 (fn collect-profile [] 543 (GLib.timeout_add 544 GLib.PRIORITY_DEFAULT 545 (* 60 1000) main-quit 546 nil nil) 547 (print "profiling for 60 seconds") 548 (profile.start 0)) 549 550 (fn watch-gnss-socket [socket-path] 551 (let [sock (socket.connect { :path socket-path :unlink true })] 552 (cq:wrap 553 (fn [] 554 (while true 555 (case (sock:xread "*L" "t") 556 l (read-gnss-sentence l) 557 (nil 11) nil 558 (nil err) (print :error err))))))) 559 560 (fn tick [] 561 ;; run cqueues scheduler 562 (case (cq:step 0) 563 ok nil 564 (nil msg code obj fd) (print "step error " msg code obj fd)) 565 (when (cq:empty) (print "cqueues controller is empty")) 566 ;; for smoother rotation when course changes, repaint more often than 567 ;; once per gnss message 568 (update-app-state {}) 569 true) 570 571 (fn run [gnss-socket] 572 (watch-gnss-socket (or gnss-socket "/var/run/gnss-share.sock")) 573 574 (GLib.timeout_add 575 GLib.PRIORITY_DEFAULT 576 100 ; ms 577 #(xpcall tick (fn [e] (print e (debug.traceback)))) 578 nil nil) 579 580 (window:add 581 (doto (Gtk.Overlay {}) 582 (: :add (osm-widget)) 583 (: :add_overlay (readouts)) 584 (: :add_overlay (arrow)) 585 (: :add_overlay (rose)) 586 )) 587 588 (window:show_all) 589 (styles) 590 (when (os.getenv "MAP_PROFILE") (collect-profile)) 591 (Gtk:main)) 592 593 594 { : run }