Daniel Barlow
ccca847e3c
* make the app-state a single-level table so we can easily copy it and check for changes * call invalidate_rect only if we've moved or changed orientation
494 lines
14 KiB
Fennel
494 lines
14 KiB
Fennel
; (local { : view } (require :fennel))
|
|
(local { : fdopen } (require :posix.stdio))
|
|
(local ptime (require :posix.time))
|
|
(local cqueues (require :cqueues))
|
|
|
|
(local nmea (require :nmea))
|
|
(local tiles (require :tiles))
|
|
|
|
(import-macros { : define-tests : expect : expect= } :assert)
|
|
|
|
(local profile
|
|
(and (os.getenv "IN_NIX_SHELL")
|
|
(require :libluaperf)))
|
|
|
|
(macro with-timing [label & body]
|
|
`(let [before# (ptime.clock_gettime ptime.CLOCK_PROCESS_CPUTIME_ID)
|
|
ret# (table.pack (do ,body))]
|
|
(let [after# (ptime.clock_gettime ptime.CLOCK_PROCESS_CPUTIME_ID)]
|
|
(print ,label (.. (- after#.tv_sec before#.tv_sec) "s "
|
|
(// (- after#.tv_nsec before#.tv_nsec) 1000) "us "))
|
|
(table.unpack ret#))))
|
|
|
|
; (with-timing :loop (for [i 1 100] (print i)))
|
|
|
|
|
|
(local {
|
|
: Gtk
|
|
: Gdk
|
|
: Gio
|
|
: GLib
|
|
: cairo
|
|
}
|
|
(require :lgi))
|
|
|
|
(local CSS "
|
|
label.readout {
|
|
font: 48px \"Noto Sans\";
|
|
margin: 10px;
|
|
padding: 5px;
|
|
background-color: rgba(0, 0, 0, 0.2);
|
|
}
|
|
")
|
|
|
|
(local utc-offset
|
|
(let [now (os.time)
|
|
localt (os.date "*t" now)
|
|
utct (os.date "!*t" now)]
|
|
(tset localt :isdst false)
|
|
(os.difftime (os.time localt) (os.time utct))))
|
|
|
|
|
|
(local viewport-width 720)
|
|
(local viewport-height 800)
|
|
(local tile-size 256)
|
|
|
|
(fn styles []
|
|
(let [style_provider (Gtk.CssProvider)]
|
|
(Gtk.StyleContext.add_provider_for_screen
|
|
(Gdk.Screen.get_default)
|
|
style_provider
|
|
Gtk.STYLE_PROVIDER_PRIORITY_APPLICATION
|
|
)
|
|
(style_provider:load_from_data CSS)))
|
|
|
|
(fn main-quit []
|
|
(when profile (profile:stop))
|
|
(Gtk.main_quit))
|
|
|
|
(local window (Gtk.Window {
|
|
:title "Map"
|
|
:name "toplevel"
|
|
:default_width viewport-width
|
|
:default_height viewport-height
|
|
|
|
:on_destroy main-quit
|
|
}))
|
|
|
|
(local state-widgets { })
|
|
|
|
(local
|
|
app-state {
|
|
:time-of-day 0
|
|
:elapsed-time 0
|
|
:speed 14
|
|
:lat 49
|
|
:lon 0
|
|
:zoom 17
|
|
:course 0 ; direction of travel
|
|
:orientation-target 0 ; map rotation angle from north
|
|
:orientation-actual 0 ; map rotation angle from north
|
|
:tiles {}
|
|
}
|
|
)
|
|
|
|
(fn merge [table1 table2]
|
|
(collect [k v (pairs table2) &into table1]
|
|
k v))
|
|
|
|
|
|
|
|
(fn map-bounds-tile [tile-x tile-y]
|
|
;; we fetch enough tiles around the current location that the screen
|
|
;; can be freely rotated without needing to fetch more.
|
|
|
|
;; when facing north, we have e.g.
|
|
;; 720 width is 2.8 * 256 pixel tiles
|
|
;; 800 height is 3.125 tiles
|
|
;;
|
|
;; however:
|
|
;; - when the map is rotated 90 degrees we instead have
|
|
;; 3.125 tiles horizontally and 2.8 vertically
|
|
;; - at e.g a 45 degree angle ... something else?
|
|
;;
|
|
;; the furthest points visible from the centre of the screen are the
|
|
;; corners. So, we draw a circle about the centre which goes
|
|
;; through those points. To ensure we have enough tiles to fill the
|
|
;; screen at any angle, we fetch every tile that's (partly
|
|
;; or entirely) inside that circle
|
|
|
|
(let [radius (/ (math.sqrt (+ (^ viewport-width 2) (^ viewport-height 2)))
|
|
tile-size 2)
|
|
min-tile-x (math.floor (- tile-x radius))
|
|
max-tile-x (math.floor (+ tile-x radius))
|
|
min-tile-y (math.floor (- tile-y radius))
|
|
max-tile-y (math.floor (+ tile-y radius))
|
|
num-tiles-x (+ 1 (- max-tile-x min-tile-x))
|
|
num-tiles-y (+ 1 (- max-tile-y min-tile-y))]
|
|
{
|
|
:min { :x min-tile-x :y min-tile-y }
|
|
:max { :x max-tile-x :y max-tile-y }
|
|
: num-tiles-x
|
|
: num-tiles-y
|
|
:pixels {
|
|
:x (* tile-size num-tiles-x)
|
|
:y (* tile-size num-tiles-y)
|
|
}
|
|
}))
|
|
|
|
;; diagonal radius is 538 pixels, 2.1 tiles
|
|
|
|
(let [bounds (map-bounds-tile 65539.5 45014.5)]
|
|
(expect= bounds.min {:x 65537 :y 45012})
|
|
(expect= bounds.max {:x 65541 :y 45016}))
|
|
|
|
(let [bounds (map-bounds-tile 65539.0 45014.0)]
|
|
(expect= bounds.min {:x 65536 :y 45011})
|
|
(expect= bounds.max {:x 65541 :y 45016})
|
|
)
|
|
|
|
(fn map-bounds [lat lon zoom]
|
|
(let [(tile-x tile-y) (tiles.latlon->tile app-state.lat app-state.lon app-state.zoom)]
|
|
(map-bounds-tile tile-x tile-y)))
|
|
|
|
(fn bounds= [a b]
|
|
(and (= a.min.x b.min.x)
|
|
(= a.min.y b.min.y)
|
|
(= a.max.x b.max.x)
|
|
(= a.max.y b.max.y)))
|
|
|
|
(local cq (cqueues.new))
|
|
|
|
(fn road-width-for [line]
|
|
(case (?. line :tags :highway)
|
|
:motorway 18
|
|
:trunk 17
|
|
:primary 16
|
|
:secondary 14
|
|
:cycleway 4
|
|
:footway 4
|
|
other 12))
|
|
|
|
(fn cairo-road-path [g [[sx sy] & points] bounds]
|
|
(let [min bounds.min
|
|
{ : line_to } g]
|
|
(g:move_to (* tile-size (- sx min.x))
|
|
(* tile-size (- sy min.y)))
|
|
(each [_ [x y] (ipairs points)]
|
|
(let [x1 (* tile-size (- x min.x))
|
|
y1 (* tile-size (- y min.y))]
|
|
(line_to g x1 y1)))))
|
|
|
|
(fn cairo-roads [g lines bounds]
|
|
(g:set_source_rgb 0 0 0)
|
|
(each [_ line (pairs lines)]
|
|
(g:set_line_width (road-width-for line))
|
|
(cairo-road-path g line.points bounds )
|
|
(g:stroke))
|
|
(g:set_source_rgb 1 1 1)
|
|
(each [_ line (pairs lines)]
|
|
(g:set_line_width (- (road-width-for line) 2))
|
|
(cairo-road-path g line.points bounds)
|
|
(g:stroke)))
|
|
|
|
|
|
(var map-surface nil)
|
|
|
|
(fn fetch-tiles [bounds tbl zoom]
|
|
(for [x bounds.min.x bounds.max.x]
|
|
(for [y bounds.min.y bounds.max.y]
|
|
(let [k (tiles.name x y zoom)]
|
|
(when (not (. tbl k))
|
|
(tiles.fetch cq x y zoom #(tset tbl k $1)))))))
|
|
|
|
(fn draw-onto-map-surface [surface bounds zoom]
|
|
(let [{ : num-tiles-x : num-tiles-y } bounds
|
|
road-width 14
|
|
lines []]
|
|
|
|
(for [x bounds.min.x bounds.max.x]
|
|
(for [y bounds.min.y bounds.max.y]
|
|
(merge lines (or (. app-state.tiles (tiles.name x y zoom)) {}))))
|
|
|
|
(let [seen-road-names {}
|
|
g (cairo.Context.create surface)]
|
|
|
|
(g:set_source_rgb 0.7 0.8 0.8)
|
|
(g:rectangle 0 0 bounds.pixels.x bounds.pixels.y)
|
|
(g:fill)
|
|
|
|
(cairo-roads g lines bounds)
|
|
|
|
(g:set_source_rgb 0.2 0.2 0.2)
|
|
(g:set_font_size (+ road-width 1))
|
|
(each [_ line (pairs lines)]
|
|
(case line.name
|
|
n (let [[tx ty angle] line.label-place
|
|
ext (g:text_extents n)
|
|
w ext.width
|
|
h ext.height]
|
|
(when (and tx ty (not (. seen-road-names n)))
|
|
(let [x (* tile-size (- tx bounds.min.x))
|
|
y (* tile-size (- ty bounds.min.y))]
|
|
(tset seen-road-names n true)
|
|
|
|
(g:save)
|
|
(g:move_to x y)
|
|
(g:rotate angle)
|
|
(g:rel_move_to (- (// w 2)) 3)
|
|
(g:text_path n)
|
|
(g:fill)
|
|
(g:restore))))))
|
|
|
|
surface)))
|
|
|
|
|
|
(fn on-osm-draw [widget g]
|
|
(let [(tile-x tile-y) (tiles.latlon->tile app-state.lat app-state.lon app-state.zoom)
|
|
bounds (map-bounds-tile tile-x tile-y)
|
|
offset-x (- (* tile-size (- tile-x bounds.min.x)) (/ viewport-width 2))
|
|
offset-y (- (* tile-size (- tile-y bounds.min.y)) (/ viewport-height 2))]
|
|
|
|
(when (not map-surface)
|
|
(let [window (widget:get_window)]
|
|
(set map-surface
|
|
(doto
|
|
(window:create_similar_surface
|
|
cairo.Content.COLOR
|
|
bounds.pixels.x
|
|
bounds.pixels.y)
|
|
(draw-onto-map-surface bounds app-state.zoom)))))
|
|
|
|
(g:translate (+ (/ viewport-width 2)) (+ (/ viewport-height 2)))
|
|
(g:rotate (* (/ (- 360 app-state.orientation-actual) 180) math.pi))
|
|
(g:translate (- (/ viewport-width 2)) (- (/ viewport-height 2)))
|
|
|
|
(g:set_source_surface map-surface (- offset-x) (- offset-y))
|
|
(g:set_operator cairo.Operator.SOURCE)
|
|
(g:paint)))
|
|
|
|
|
|
|
|
(fn register-widget [name widget]
|
|
(tset state-widgets name widget)
|
|
widget)
|
|
|
|
(fn osm-widget []
|
|
(register-widget
|
|
:osm
|
|
(Gtk.DrawingArea {
|
|
:width viewport-width :height viewport-height
|
|
:on_draw on-osm-draw
|
|
})))
|
|
|
|
(fn readout [name text]
|
|
(register-widget
|
|
name
|
|
(doto (Gtk.Label {:label text : name})
|
|
(-> (: :get_style_context)
|
|
(: :add_class :readout)))))
|
|
|
|
(local knot-in-m-s
|
|
(/ 1852 ; metres in nautical mile
|
|
3600 ; seconds in an hour
|
|
))
|
|
|
|
(fn hhmmss [seconds-since-midnight]
|
|
(let [s (% seconds-since-midnight 60)
|
|
m (% (// (- seconds-since-midnight s) 60) 60)
|
|
h (// (- seconds-since-midnight (* m 60) s) 3600)]
|
|
(string.format "%d:%02d:%02d" h m s)))
|
|
|
|
(expect= (hhmmss (+ 45 (* 60 12) (* 60 60 3))) "3:12:45")
|
|
|
|
|
|
(fn update-app-state [new-vals]
|
|
(let [old-state (merge {} app-state)
|
|
old-bounds
|
|
(map-bounds app-state.lat app-state.lon app-state.zoom)]
|
|
(merge app-state new-vals)
|
|
(let [bounds
|
|
(map-bounds app-state.lat app-state.lon app-state.zoom)]
|
|
(when (not (bounds= old-bounds bounds))
|
|
(fetch-tiles bounds app-state.tiles app-state.zoom)
|
|
(set map-surface nil)))
|
|
|
|
(when (> (math.abs (- app-state.orientation-target app-state.course)) 20)
|
|
(set app-state.orientation-target app-state.course)
|
|
; (-> state-widgets.rose (: :get_window) (: :invalidate_rect nil))
|
|
(set map-surface nil))
|
|
|
|
(when (not (= app-state.orientation-target app-state.orientation-actual))
|
|
(set app-state.orientation-actual
|
|
(+ app-state.orientation-actual
|
|
(* 0.05 (- app-state.orientation-target app-state.orientation-actual))))
|
|
)
|
|
|
|
(each [name widget (pairs state-widgets)]
|
|
(case name
|
|
:speed (widget:set_label
|
|
(string.format "%.1f km/h" (* app-state.speed 3.6)))
|
|
:osm
|
|
(when (not (and ; false
|
|
(= old-state.lat app-state.lat)
|
|
(= old-state.lon app-state.lon)
|
|
(= old-state.orientation-actual
|
|
app-state.orientation-actual)
|
|
))
|
|
(: (widget:get_window) :invalidate_rect nil))
|
|
:arrow (: (widget:get_window) :invalidate_rect nil)
|
|
:rose (: (widget:get_window) :invalidate_rect nil)
|
|
:time (widget:set_label
|
|
(hhmmss (+ utc-offset app-state.time-of-day)))
|
|
))))
|
|
|
|
|
|
(fn readouts []
|
|
(doto (Gtk.Box
|
|
{
|
|
:orientation Gtk.Orientation.VERTICAL
|
|
:halign Gtk.Align.END
|
|
})
|
|
(-> (: :get_style_context) (: :add_class :readouts))
|
|
(: :add (readout :time ""))
|
|
(: :add (readout :elapsed-time ""))
|
|
(: :add (readout :speed "0"))))
|
|
|
|
(fn arrow []
|
|
(let [height 40]
|
|
(register-widget
|
|
:arrow
|
|
(Gtk.Label {
|
|
:halign Gtk.Align.CENTER
|
|
:valign Gtk.Align.CENTER
|
|
:width height :height height
|
|
:on_draw
|
|
(fn [self g]
|
|
(g:set_source_rgb 0.4 0.0 0.1)
|
|
(g:translate (// height 2) (// height 2))
|
|
(g:rotate (* (/ (- app-state.course app-state.orientation-actual)
|
|
180) math.pi))
|
|
(g:translate (// height -2) (// height -2))
|
|
(g:set_line_width 4)
|
|
(g:move_to 10 height)
|
|
(g:line_to (// height 2) 0)
|
|
(g:line_to (- height 10) height)
|
|
(g:fill)
|
|
true)
|
|
}))))
|
|
|
|
(fn deg->rad [degrees]
|
|
(* math.pi (/ degrees 180)))
|
|
|
|
(fn rose []
|
|
(let [height 60]
|
|
(register-widget
|
|
:rose
|
|
(Gtk.Label {
|
|
:halign Gtk.Align.START
|
|
:valign Gtk.Align.START
|
|
:width height :height height
|
|
:on_draw
|
|
(fn [self g]
|
|
(g:save)
|
|
(g:set_line_width 1)
|
|
(g:set_source_rgb 0.4 0.0 0.1)
|
|
(g:arc (// height 2) (// height 2) 15
|
|
0 (* 2 math.pi))
|
|
(g:stroke)
|
|
|
|
(g:translate (// height 2) (// height 2))
|
|
(g:rotate (- (deg->rad app-state.orientation-actual)))
|
|
(g:translate (// height -2) (// height -2))
|
|
|
|
(g:set_line_width 2)
|
|
(g:move_to (// height 2) height)
|
|
(g:line_to (// height 2) 0)
|
|
|
|
(g:move_to 10 20)
|
|
(g:line_to (// height 2) 0)
|
|
(g:line_to (- height 10) 20)
|
|
(g:stroke)
|
|
|
|
(g:set_source_rgb 1 1 0)
|
|
(g:move_to (// height -2) (// height -2))
|
|
(g:text_path "N")
|
|
(g:fill)
|
|
|
|
(g:restore)
|
|
true)
|
|
}))))
|
|
|
|
|
|
(local socket-path (or (. arg 1) "/var/run/gnss-share.sock"))
|
|
|
|
(local gnss-socket
|
|
(let [addr (Gio.UnixSocketAddress {
|
|
:path socket-path
|
|
})]
|
|
(: (Gio.SocketClient) :connect addr nil)))
|
|
|
|
(fn read-gnss [socket]
|
|
(each [l #(socket:read "l")]
|
|
; (print "gnss" l)
|
|
(if (not (= l ""))
|
|
(let [message (nmea.parse l)]
|
|
(case message
|
|
{ : lat : lon : utc}
|
|
(update-app-state
|
|
{
|
|
: lat : lon
|
|
:time-of-day
|
|
(let [(h m s) (string.match utc "(..)(..)(..)")]
|
|
(+ s (* m 60) (* h 60 60)))
|
|
}
|
|
)
|
|
{ : speed-knots }
|
|
(update-app-state { :speed (* speed-knots knot-in-m-s) }))
|
|
(if message.bearing-true
|
|
(update-app-state { :course message.bearing-true }))
|
|
)))
|
|
true)
|
|
|
|
(let [sock (gnss-socket:get_socket)
|
|
fd (sock:get_fd)
|
|
events [ GLib.IOCondition.IN GLib.IOCondition.HUP]
|
|
channel (GLib.IOChannel.unix_new fd)
|
|
handle (fdopen fd :r)]
|
|
(GLib.io_add_watch channel 0 events #(read-gnss handle)))
|
|
|
|
|
|
(GLib.timeout_add
|
|
GLib.PRIORITY_DEFAULT
|
|
100 ; ms
|
|
(fn []
|
|
;; run cqueues scheduler
|
|
(cq:step 0)
|
|
;; for smoother rotation when course changes, repaint more often than
|
|
;; once per gnss message
|
|
(update-app-state {})
|
|
true)
|
|
nil nil)
|
|
|
|
(fn collect-profile []
|
|
(GLib.timeout_add
|
|
GLib.PRIORITY_DEFAULT
|
|
(* 60 1000) main-quit
|
|
nil nil)
|
|
(print "profiling for 60 seconds")
|
|
(profile.start 0))
|
|
|
|
|
|
(window:add
|
|
(doto (Gtk.Overlay {})
|
|
(: :add (osm-widget))
|
|
(: :add_overlay (readouts))
|
|
(: :add_overlay (arrow))
|
|
(: :add_overlay (rose))
|
|
))
|
|
|
|
(window:show_all)
|
|
(styles)
|
|
(when (os.getenv "MAP_PROFILE") (collect-profile))
|
|
(Gtk:main)
|