Daniel Barlow
8ec64bb1b0
there is a bit of smoothing so it does not instantly lurch to the new new course, as the visual effect was quite jarring
420 lines
12 KiB
Fennel
420 lines
12 KiB
Fennel
; (local { : view } (require :fennel))
|
|
(local { : fdopen } (require :posix.stdio))
|
|
(local cqueues (require :cqueues))
|
|
|
|
(local nmea (require :nmea))
|
|
(local tiles (require :tiles))
|
|
|
|
(import-macros { : define-tests : expect : expect= } :assert)
|
|
|
|
(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)))
|
|
|
|
(local window (Gtk.Window {
|
|
:title "Map"
|
|
:name "toplevel"
|
|
:default_width viewport-width
|
|
:default_height viewport-height
|
|
|
|
:on_destroy Gtk.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
|
|
:smooth-course 0
|
|
}
|
|
)
|
|
|
|
(fn merge [table1 table2]
|
|
(collect [k v (pairs table2) &into table1]
|
|
k v))
|
|
|
|
|
|
|
|
(fn map-bounds-tile [tile-x tile-y]
|
|
(let [min-tile-x (math.floor (- tile-x (/ viewport-width tile-size 2)))
|
|
max-tile-x (math.floor (+ tile-x (/ viewport-width tile-size 2)))
|
|
min-tile-y (math.floor (- tile-y (/ viewport-height tile-size 2)))
|
|
max-tile-y (math.floor (+ tile-y (/ viewport-height tile-size 2)))
|
|
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)
|
|
}
|
|
}))
|
|
|
|
;; 720 width is 2.8 * 256 pixel tiles
|
|
;; 800 height is 3.125 tiles
|
|
|
|
(let [bounds (map-bounds-tile 65539.5 45014.5)]
|
|
;; tile 65539, 45014 is centred on screen. left of it there is space
|
|
;; for one tile and right of it likewise.
|
|
;; vertical space for other tiles is (/ (- viewport-height tile-size) 256)
|
|
;; => 2.125 tiles, shared equally to top and bottom therefore
|
|
;; 1.0625 tiles above and 1.0625 tiles below
|
|
|
|
(expect= bounds.min {:x 65538 :y 45012})
|
|
(expect= bounds.max {:x 65540 :y 45016}))
|
|
|
|
(let [bounds (map-bounds-tile 65539.0 45014.0)]
|
|
;; top left corner of tile 65539, 45014 is centred on screen.
|
|
;; to its left there are 360 pixels, so we need two tiles
|
|
;; to its right there are 104 pixels, so one tile
|
|
;; above there are 400 pixels: two tiles
|
|
;; below are 144 pixels: one tile
|
|
|
|
(expect= bounds.min {:x 65537 :y 45012})
|
|
(expect= bounds.max {:x 65540 :y 45015})
|
|
)
|
|
|
|
(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)))
|
|
|
|
|
|
|
|
(local cq (cqueues.new))
|
|
|
|
(fn road-width-for [line offset]
|
|
(+ (or offset 0)
|
|
(case (?. line :tags :highway)
|
|
:motorway 18
|
|
:trunk 17
|
|
:primary 16
|
|
:secondary 14
|
|
:cycleway 4
|
|
:footway 4
|
|
other (do (print "highway " other) 12))))
|
|
|
|
(fn cairo-road-path [g [[sx sy] & points] bounds width]
|
|
(g:save)
|
|
(g:set_line_width width)
|
|
(g:move_to (* tile-size (- sx bounds.min.x))
|
|
(* tile-size (- sy bounds.min.y)))
|
|
(each [_ [x y] (ipairs points)]
|
|
(let [x1 (* tile-size (- x bounds.min.x))
|
|
y1 (* tile-size (- y bounds.min.y))]
|
|
(g:line_to x1 y1)))
|
|
(g:stroke)
|
|
(g:restore))
|
|
|
|
|
|
(fn cairo-roads [g lines bounds]
|
|
(let [road-width 14]
|
|
(g:set_source_rgb 0 0 0)
|
|
(each [_ line (pairs lines)]
|
|
(cairo-road-path g line.points bounds (road-width-for line)))
|
|
(g:set_source_rgb 1 1 1)
|
|
(each [_ line (pairs lines)]
|
|
(cairo-road-path g line.points bounds (road-width-for line -2)))))
|
|
|
|
(fn label-coords [{ : points } bounds]
|
|
(var biggest 0)
|
|
(var biggest-n 0)
|
|
|
|
(for [i 2 (# points)]
|
|
(let [[x1 y1] (. points (- i 1))
|
|
[x2 y2] (. points i)
|
|
dist
|
|
(+ (* (- x2 x1) (- x2 x1))
|
|
(* (- y2 y1) (- y2 y1)))]
|
|
(when (>= dist biggest)
|
|
(set biggest dist)
|
|
(set biggest-n (- i 1)))))
|
|
(let [[x y] (. points biggest-n)
|
|
[nx ny] (. points (+ 1 biggest-n))
|
|
angle (math.atan (- ny y) (- nx x))]
|
|
(if (> nx x)
|
|
(values
|
|
(* tile-size (- x bounds.min.x))
|
|
(* tile-size (- y bounds.min.y))
|
|
angle)
|
|
(values ; if way runs r->l, prefer label to read l->r
|
|
(* tile-size (- nx bounds.min.x))
|
|
(* tile-size (- ny bounds.min.y))
|
|
(+ math.pi angle)))))
|
|
|
|
(var map-surface nil)
|
|
|
|
(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 (tiles.polylines cq x y zoom
|
|
#(set map-surface nil)
|
|
))))
|
|
|
|
(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 [(x y angle) (label-coords line bounds)
|
|
ext (g:text_extents n)
|
|
w ext.width
|
|
h ext.height]
|
|
(when (and x y (not (. seen-road-names n)))
|
|
(tset seen-road-names n true)
|
|
(g:save)
|
|
(g:set_line_width h)
|
|
(g:set_source_rgba 1 0.95 1 0.7)
|
|
(g:move_to (- x 1) (- y 1))
|
|
(g:rotate angle)
|
|
(g:rel_line_to (+ w 1) 0)
|
|
(g:stroke)
|
|
(g:restore)
|
|
|
|
(g:save)
|
|
(g:move_to x y)
|
|
(g:rotate angle)
|
|
(g:rel_move_to 0 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.smooth-course) 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:rectangle 0 0 viewport-width viewport-height)
|
|
(g:fill)))
|
|
|
|
|
|
|
|
(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-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 (or
|
|
(not (= old-bounds.min.x bounds.min.x))
|
|
(not (= old-bounds.min.y bounds.min.y)))
|
|
(set map-surface nil)))
|
|
(set app-state.smooth-course
|
|
(+ app-state.smooth-course
|
|
(* 0.05 (- app-state.course app-state.smooth-course))))
|
|
(each [name widget (pairs state-widgets)]
|
|
(case name
|
|
:speed (widget:set_label
|
|
(string.format "%.1f km/h" (* app-state.speed 3.6)))
|
|
:osm (: (widget:get_window) :invalidate_rect nil)
|
|
:arrow (: (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.smooth-course)
|
|
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)
|
|
}))))
|
|
|
|
|
|
(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
|
|
20 ; 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)
|
|
|
|
(window:add
|
|
(doto (Gtk.Overlay {})
|
|
(: :add (osm-widget))
|
|
(: :add_overlay (readouts))
|
|
(: :add_overlay (arrow))
|
|
))
|
|
|
|
(window:show_all)
|
|
(styles)
|
|
(Gtk:main)
|