clobber map-surface when bounds change

This massively reduces cpu usage, however it doesn't yet work
if we've moved far enough that we'd need to fetch new tiles.

pkgs/maps/default.nix

@@ -2,6 +2,7 @@
 , pkg-config
 , buildPackages
 , callPackage
+, cairo
 , clutter
 , fetchFromGitHub
 , fetchurl
@@ -52,8 +53,8 @@ in stdenv.mkDerivation {
   buildInputs = [
     lua
     gtk3.dev
+    cairo.dev
     gobject-introspection
-    osm-gps-map
     glib-networking
   ];
   nativeBuildInputs = [

pkgs/maps/main.fnl

@@ -10,6 +10,7 @@
         : Gdk
         : Gio
         : GLib
+        : cairo
         }
        (require :lgi))
 
@@ -70,52 +71,94 @@ label.readout {
   (collect [k v (pairs table2) &into table1]
     k v))
 
-;; given  lat/lon
-;; we want the tile containing lat to be roughly centred
-;; on the screen, and enough tiles either side of it
-;; to fill the width of the screen plus a bit
 
-(fn osm-widget []
-  (let [height tile-size
-        num-tiles-x (+ 1 (math.ceil (/ map-width tile-size)))
+
+(fn map-bounds [lat lon zoom]
+  (let [num-tiles-x (+ 1 (math.ceil (/ map-width tile-size)))
         num-tiles-y (+ 1 (math.ceil (/ map-height tile-size)))
         (tile-x tile-y) (tiles.latlon->tile app-state.lat app-state.lon app-state.zoom)
         min-tile-x (math.floor (- tile-x (/ num-tiles-x 2)))
-        max-tile-x (math.ceil (+ tile-x (/ num-tiles-x 2)))
+        max-tile-x (+ min-tile-x num-tiles-x 4)
         min-tile-y (math.floor (- tile-y (/ num-tiles-y 2)))
-        max-tile-y (math.ceil  (+ tile-y (/ num-tiles-y 2)))
+        max-tile-y (+ min-tile-y num-tiles-y 4)]
+    {
+     :min { :x min-tile-x :y min-tile-y }
+     :max { :x max-tile-x :y max-tile-y }
+     : num-tiles-x : num-tiles-y
+     }))
+
+(fn cairo-the-map [window]
+  (let [{ : lat : lon : zoom } app-state
+        { : num-tiles-x : num-tiles-y &as bounds } (map-bounds lat lon zoom)
         lines []]
 
-    (for [x min-tile-x max-tile-x]
-      (for [y min-tile-y max-tile-y]
-        (print :x x :y y)
-        (merge lines (tiles.polylines x y app-state.zoom))))
+    (for [x bounds.min.x bounds.max.x]
+      (for [y bounds.min.y bounds.max.y]
+        (merge lines (tiles.polylines x y zoom))))
 
-    (Gtk.Label {
-                :width height :height height
-                :on_draw
-                (fn [self g]
-                  (print app-state.lat app-state.lon )
-                  (g:set_source_rgb 0.2 0.2 0.4)
-                  (g:set_line_width 3)
+    (let [map-surface
+          (window:create_similar_surface
+           cairo.Content.COLOR
+           (* tile-size (+ 4 num-tiles-x))
+           (* tile-size (+ 4 num-tiles-y)))
+          g (cairo.Context.create map-surface)]
+
+      (g:set_source_rgb 1 1 1)
+      (g:rectangle 0 0 (* tile-size num-tiles-x) (* tile-size num-tiles-y))
+      (g:fill)
+
+      (g:set_source_rgb 0.2 0.2 0.6)
+      (g:set_line_width 2)
       (each [_ line (pairs lines)]
         (case line
           [[sx sy] & more]
           (do
-                        (g:move_to sx sy)
+            (g:move_to (* tile-size (- sx bounds.min.x))
+                       (* tile-size (- sy bounds.min.y)))
             (each [_ [x y] (ipairs more)]
-                          (g:line_to x y)))))
+              (let [x1 (* tile-size (- x bounds.min.x))
+                    y1 (* tile-size (- y bounds.min.y))]
+                (g:line_to x1 y1))))))
       (g:stroke)
-                  true)
+      map-surface)))
+
+(var map-surface nil)
+
+(fn on-osm-draw [widget g]
+  (when (not map-surface)
+    (let [window (widget:get_window)]
+      (set map-surface (cairo-the-map window))))
+
+  (let [(tile-x tile-y) (tiles.latlon->tile app-state.lat app-state.lon app-state.zoom)
+        bounds (map-bounds tile-x tile-y)
+        offset-x (- (* tile-size (- tile-x bounds.min.x)) (/ map-width 2))
+        offset-y (- (* tile-size (- tile-y bounds.min.y)) (/ map-height 2))]
+
+    (g:set_source_surface map-surface (- offset-x) (- offset-y))
+    (g:set_operator cairo.Operator.SOURCE)
+    (g:rectangle 0 0 map-width map-height)
+    (g:fill)))
+
+
+
+(fn register-widget [name widget]
+  (tset state-widgets name widget)
+  widget)
+
+(fn osm-widget []
+  (register-widget
+   :osm
+   (Gtk.DrawingArea {
+                     :width map-width :height map-height
+                     :on_draw on-osm-draw
                      })))
 
 (fn readout [name text]
-  (let [w
+  (register-widget
+   name
    (doto (Gtk.Label {:label text : name})
      (-> (: :get_style_context)
-              (: :add_class :readout)))]
-    (tset state-widgets name w)
-    w))
+         (: :add_class :readout)))))
 
 (local knot-in-m-s
        (/ 1852 ; metres in nautical mile
@@ -135,15 +178,24 @@ label.readout {
 
 
 (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)))
     (each [name widget (pairs state-widgets)]
       (case name
         :speed (widget:set_label
                 (string.format "%.1f km/h" (* app-state.speed 3.6)))
-      :osm (widget:set_center app-state.lat app-state.lon)
+        :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 []
@@ -158,8 +210,10 @@ label.readout {
     (: :add (readout :speed "0"))))
 
 (fn arrow []
-  (let [height 40
-        w (Gtk.Label {
+  (let [height 40]
+    (register-widget
+     :arrow
+     (Gtk.Label {
                  :halign Gtk.Align.CENTER
                  :valign Gtk.Align.CENTER
                  :width height :height height
@@ -175,8 +229,7 @@ label.readout {
                    (g:line_to (- height 10) height)
                    (g:fill)
                    true)
-                       })]
-    w))
+                 }))))
 
 
 (local socket-path (or (. arg 1) "/var/run/gnss-share.sock"))

pkgs/maps/tiles.fnl

@@ -45,7 +45,6 @@
 
 (fn overpass [lat lon zoom]
   (let [width (/ 360 (^ 2 zoom))
-        _ (print :w zoom width)
         n (+ lat width)                 ;XXX adjust for latitude
         w (- lon width)
         s lat
@@ -59,7 +58,7 @@
       ]
      (table.concat  "\n"))))
 
-(fn canvas [elements offset-x offset-y]
+(fn canvas [elements]
   (let [nodes {}
         lines {}]
     (each [_ e (ipairs elements)]
@@ -73,22 +72,46 @@
            (let [node (. nodes nd)
                  (tx ty) (latlon->tile node.lat node.lon 17)]
              ;;(print e.tags.name e.id e.name node.lat node.lon)
-             [ (* 256 (- tx offset-x)) (* 256  (- ty offset-y)) ])))))
+             [ tx ty  ])))))
     lines))
 
-(fn polylines [x y zoom]
+
+(fn file-exists? [name]
+  (match (io.open name :r)
+    f (do (f:close) true)
+    _ false))
+
+(fn unparsed-from-disk [x y zoom fetch-fn]
+  (let [k (..  x "_" y "_" zoom)
+        pathname (.. "/tmp/tiles/" k ".json")]
+    (if (file-exists? pathname)
+        (with-open [i (io.open pathname :r)]
+          (i:read "*a"))
+        (with-open [j (io.open pathname :w)]
+          (let [g (fetch-fn)]
+            (j:write g)
+            g)))))
+
+(fn unparsed-for-xyz [x y zoom]
     (let [(lat lon) (tile->latlon x y zoom)
         o (overpass lat lon zoom)
-        _ (print :polylines x y  o)
         r
         (req.new_from_uri
          "https://overpass-api.de/api/interpreter")
         query  { :data o }]
     (tset r.headers ":method" "POST")
     (r:set_body (dict_to_query query))
-    (let [(headers stream) (r:go)
-          (tx ty) (latlon->tile lat lon zoom)
-          data (json.decode (stream:get_body_as_string))]
-      (canvas data.elements (math.floor tx) (math.floor ty)))))
+    (let [(headers stream) (r:go)]
+      (stream:get_body_as_string))))
 
-{ : polylines : latlon->tile }
+(fn polylines-from-net [x y zoom]
+  (let [s (unparsed-from-disk
+           x y zoom
+           (fn []
+             (unparsed-for-xyz x y zoom)))
+        ;_ (print :unoparsed (s:sub 1 40))
+        data (json.decode s)]
+    (canvas data.elements)))
+
+
+{ :polylines polylines-from-net : latlon->tile }