print each road name once only

we use cqueues, which is the async framework that lua-http is built
on. we integrate it into the glib event loop rather hackily by calling
the cqueues event stepper ever 20ms from a glib timeout function

overpass has very low rate limits so we handle a 429 response by
sleeping for a random length of time and retrying. This is, also,
a bit of a hack

README

@@ -19,8 +19,6 @@ write the app in fennel. I want it to
 - show where I am on a map
 - record trail of where I've been (note: indoor counts too)
 
-
-
 can we somehow do non-flakey bluetooth (is it dbus?)
 
 
@@ -88,11 +86,6 @@ elapsed time: what should it actually show? moving time, I guess
 
 should we rename bearing as course in nmea?
 
-rotating the map is going to be complicated because the widget we're
-using doesn't support it (bitmapped map tiles)
-
-
-
 perhaps we need a server-side component for route planning
 
 
@@ -106,9 +99,9 @@ we can't rotate the map using OsmGpsMap widget because the labels will
 be sideways or upside down, so we need something with vectors that we
 can rotate
 
-a) we can get data from overpass api as json
+[done] a) we can get data from overpass api as json
 
-b) we would like to cache the results, which means some kind of
+[done badly] b) we would like to cache the results, which means some kind of
 chunking or tiling so that the json for position a is the same as the
 json for position b.
 
@@ -119,17 +112,44 @@ do it by hand -
 - minor roads
 - major roads
 
-or so something smart but complicated like "only return ways that
+or do something smart but complicated like "only return ways that
 cover more than 1/16th the length of the tile"
 
-d) I think we will need some kind of server so that multiple users get
+d) render ways according to their type (road/cycleway/path/etc)
-the benefit of the caching. If we're going to do that, should it also
-do transformation e.g. from lat/long to x/y co-ordinates? We don't
-need this bit yet though
 
-3) alternatively we could use mapbox vector tiles, but tbh I'm
+e) label the ways
-struggling to see now that helps. we don't have to transform from
+
-lat/long but instead we have to parse a protobuf, how is that simpler?
+f) async tile fetching
+
+we don't want everything to stop when it's time to fetch a new
+row of tiles, what are our options? lua-http is built on cqueues
+which is async enough to make my head hurt, but we also need
+to make it coexist with the gtk event loop
+
+assumptions:
+1) gtk stuff has to happen in the main thread (whatever that is...)
+so we can't control it from cqueues because that has its own
+threading stuff
+2) there will be lots of fds from lua-http, do we really want the
+housekeeping of making GLib.io_add_watch for each of them? it looks
+like adding a glib source from lgi is not currently practical
+https://github.com/lgi-devs/lgi/issues/111
+
+3) if we put http calls inside cq:wrap, that make them background
+provided that we call (cq:step 0)
+periodically. we could do that in a glib idle function, perhaps.
+
+- The tile fetcher would need to know where to write the data when
+  eventually it comes back
+- need some say to not fetch the same tile 18 times if there's more than
+  one request for it while a previous request is in progress
+
+
+---- 
+
+https://git.syndicate-lang.org/tonyg/squeak-phone/raw/commit/474960ddc665ed445a1f5afb0164fe39057720f9/devices/pine64-pinephone/modem-docs/80545ST10798A_LM940_QMI_Command_Reference_Guide_r3.pdf
+
+----
 
 
 

pkgs/maps/default.nix

@@ -2,6 +2,7 @@
 , pkg-config
 , buildPackages
 , callPackage
+, cairo
 , clutter
 , fetchFromGitHub
 , fetchurl
@@ -30,8 +31,8 @@ let
     src = fetchFromGitHub {
       owner = "lgi-devs";
       repo = "lgi";
-      rev = "e06ad94c8a1c84e3cdb80cee293450a280dfcbc7";
+      rev = "a412921fad445bcfc05a21148722a92ecb93ad06";
-      hash = "sha256-VYr/DV1FAyzPe6p6Quc1nmsHup23IAMfz532rL167Q4=";
+      hash = "sha256-kZBpH5gcaCNU134Wn6JXAkFELzmiphc1PeCtmN9cagc=";
     };
   };
   rxi-json = callPackage ../rxi-json { lua = lua5_3; };
@@ -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

@@ -1,5 +1,7 @@
 ; (local { : view } (require :fennel))
 (local { : fdopen } (require :posix.stdio))
+(local cqueues (require :cqueues))
+
 (local nmea (require :nmea))
 (local tiles (require :tiles))
 
@@ -10,6 +12,7 @@
         : Gdk
         : Gio
         : GLib
+        : cairo
         }
        (require :lgi))
 
@@ -30,7 +33,9 @@ label.readout {
          (os.difftime (os.time localt) (os.time utct))))
 
 
-
+(local map-width 720)
+(local map-height 800)
+(local tile-size 256)
 
 (fn styles []
   (let [style_provider (Gtk.CssProvider)]
@@ -44,8 +49,8 @@ label.readout {
 (local window (Gtk.Window {
                            :title "Map"
                            :name "toplevel"
-                           :default_width 720
+                           :default_width map-width
-                           :default_height 800
+                           :default_height map-height
 
                            :on_destroy Gtk.main_quit
                            }))
@@ -59,38 +64,165 @@ label.readout {
             :speed 14
             :lat 49
             :lon 0
+            :zoom 17
             :course 22
             }
  )
 
+(fn merge [table1 table2]
+  (collect [k v (pairs table2) &into table1]
+    k v))
+
+
+
+(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 (+ min-tile-x num-tiles-x 4)
+        min-tile-y (math.floor (- 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
+     }))
+
+(local cq (cqueues.new))
+
+(fn cairo-roads-path [g lines bounds]
+  (each [_ line (pairs lines)]
+    (case line.points
+      [[sx sy] & more]
+      (do
+        (g:save)
+        (g:move_to (* tile-size (- sx bounds.min.x))
+                   (* tile-size (- sy bounds.min.y)))
+        (each [_ [x y] (ipairs more)]
+          (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 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))]
+    (values
+     (* tile-size (- x bounds.min.x))
+     (* tile-size (- y bounds.min.y))
+     angle)))
+
+
+(fn cairo-the-map [window]
+  (let [{ : lat : lon : zoom } app-state
+        { : num-tiles-x : num-tiles-y &as bounds } (map-bounds lat lon zoom)
+        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))))
+
+    (let [map-surface
+          (window:create_similar_surface
+           cairo.Content.COLOR
+           (* tile-size (+ 4 num-tiles-x))
+           (* tile-size (+ 4 num-tiles-y)))
+          seen-road-names {}
+          g (cairo.Context.create map-surface)]
+
+      (g:set_source_rgb 0.7 0.8 0.8)
+      (g:rectangle 0 0 (* tile-size num-tiles-x) (* tile-size num-tiles-y))
+      (g:fill)
+
+      (g:set_source_rgb 0 0 0)
+      (g:set_line_width road-width)
+      (cairo-roads-path g lines bounds)
+      (g:set_source_rgb 1 1 1)
+      (g:set_line_width (- road-width 2))
+      (cairo-roads-path 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_rgb 1 1 1)
+                (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)))))
+
+      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 []
-  (let [height 256]
+  (register-widget
-    (Gtk.Label {
+   :osm
-                :width height :height height
+   (Gtk.DrawingArea {
-                :on_draw
+                     :width map-width :height map-height
-                (fn [self g]
+                     :on_draw on-osm-draw
-                  (print app-state.lat app-state.lon )
+                     })))
-                  (let [lines (tiles.polylines app-state.lat app-state.lon 17)]
-                    (g:set_source_rgb 0.2 0.2 0.4)
-                    (g:set_line_width 3)
-                    (each [_ line (ipairs lines)]
-                      (case line
-                        [[sx sy] & more]
-                        (do
-                          (g:move_to sx sy)
-                          (each [_ [x y] (ipairs more)]
-                            (g:line_to x y)))))
-                    (g:stroke)
-                    true))
-                })))
 
 (fn readout [name text]
-  (let [w
+  (register-widget
-        (doto (Gtk.Label {:label text : name})
+   name
-          (-> (: :get_style_context)
+   (doto (Gtk.Label {:label text : name})
-              (: :add_class :readout)))]
+     (-> (: :get_style_context)
-    (tset state-widgets name w)
+         (: :add_class :readout)))))
-    w))
 
 (local knot-in-m-s
        (/ 1852 ; metres in nautical mile
@@ -106,21 +238,28 @@ label.readout {
 (expect= (hhmmss (+ 45 (* 60 12) (* 60 60 3))) "3:12:45")
 
 
-(fn merge [table1 table2]
+
-  (collect [k v (pairs table2) &into table1]
-    k v))
 
 
 (fn update-app-state [new-vals]
-  (merge app-state new-vals)
+  (let [old-bounds
-  (each [name widget (pairs state-widgets)]
+        (map-bounds app-state.lat app-state.lon app-state.zoom)]
-    (case name
+    (merge app-state new-vals)
-      :speed (widget:set_label
+    (let [bounds
-              (string.format "%.1f km/h" (* app-state.speed 3.6)))
+          (map-bounds app-state.lat app-state.lon app-state.zoom)]
-      :osm (widget:set_center app-state.lat app-state.lon)
+      (when (or
-      :time (widget:set_label
+             (not (= old-bounds.min.x bounds.min.x))
-             (hhmmss (+ utc-offset app-state.time-of-day)))
+             (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: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 []
@@ -135,25 +274,26 @@ label.readout {
     (: :add (readout :speed "0"))))
 
 (fn arrow []
-  (let [height 40
+  (let [height 40]
-        w (Gtk.Label {
+    (register-widget
-                       :halign Gtk.Align.CENTER
+     :arrow
-                       :valign Gtk.Align.CENTER
+     (Gtk.Label {
-                       :width height :height height
+                 :halign Gtk.Align.CENTER
-                       :on_draw
+                 :valign Gtk.Align.CENTER
-                       (fn [self g]
+                 :width height :height height
-                         (g:set_source_rgb 0.4 0.0 0.1)
+                 :on_draw
-                         (g:translate (// height 2) (// height 2))
+                 (fn [self g]
-                         (g:rotate (/ (* -2  app-state.course math.pi) 360) )
+                   (g:set_source_rgb 0.4 0.0 0.1)
-                         (g:translate (// height -2) (// height -2))
+                   (g:translate (// height 2) (// height 2))
-                         (g:set_line_width 4)
+                   (g:rotate (/ (* -2  app-state.course math.pi) 360) )
-                         (g:move_to 10 height)
+                   (g:translate (// height -2) (// height -2))
-                         (g:line_to (// height 2) 0)
+                   (g:set_line_width 4)
-                         (g:line_to (- height 10) height)
+                   (g:move_to 10 height)
-                         (g:fill)
+                   (g:line_to (// height 2) 0)
-                         true)
+                   (g:line_to (- height 10) height)
-                       })]
+                   (g:fill)
-    w))
+                   true)
+                 }))))
 
 
 (local socket-path (or (. arg 1) "/var/run/gnss-share.sock"))
@@ -194,6 +334,14 @@ label.readout {
   (GLib.io_add_watch channel 0 events #(read-gnss handle)))
 
 
+(GLib.timeout_add
+ GLib.PRIORITY_DEFAULT
+ 20 ; ms
+ (fn []
+   (cq:step 0)
+   true)
+ nil nil)
+
 (window:add
  (doto (Gtk.Overlay {})
    (: :add (osm-widget))

pkgs/maps/tiles.fnl

@@ -1,6 +1,7 @@
 (local req (require :http.request))
 (local { : dict_to_query } (require :http.util))
 (local json (require :json))
+(local cqueues (require :cqueues))
 
 (import-macros { : define-tests : expect : expect= : expect-near } :assert)
 (local { : view } (require :fennel))
@@ -43,9 +44,10 @@
   (expect= (math.floor y) 43221))
 
 
-(fn overpass [lat lon]
+(fn overpass [lat lon zoom]
-  (let [n (+ lat 0.01)
+  (let [width (/ 360 (^ 2 zoom))
-        w (- lon 0.01)
+        n (+ lat width)                 ;XXX adjust for latitude
+        w (- lon width)
         s lat
         e lon]
     (->
@@ -57,32 +59,81 @@
       ]
      (table.concat  "\n"))))
 
-(fn canvas [elements offset-x offset-y]
+(fn canvas [elements zoom]
   (let [nodes {}
-        lines []]
+        lines {}]
     (each [_ e (ipairs elements)]
       (case e.type
         :node (tset nodes e.id e)
         :way
-        (table.insert
+        (tset
          lines
-         (icollect [_ nd (ipairs e.nodes)]
+         e.id
-           (let [node (. nodes nd)
+         {
-                 (tx ty) (latlon->tile node.lat node.lon 17)]
+          :name (?. e :tags :name)
-             ;;(print e.tags.name e.id e.name node.lat node.lon)
+          :points
-             [ (* 256 (- tx offset-x)) (* 256  (- ty offset-y)) ])))))
+          (icollect [_ nd (ipairs e.nodes)]
+            (let [node (. nodes nd)
+                  (tx ty) (latlon->tile node.lat node.lon zoom)]
+              ;;(print e.tags.name e.id e.name node.lat node.lon)
+              [ tx ty  ]))
+          })))
     lines))
 
-(fn polylines [lat long zoom]
+
-  (let [r
+(fn file-exists? [name]
+  (match (io.open name :r)
+    f (do (f:close) true)
+    _ false))
+
+(fn unparsed-for-xyz [x y zoom]
+  (let [(lat lon) (tile->latlon x y zoom)
+        o (overpass lat lon zoom)
+        r
         (req.new_from_uri
          "https://overpass-api.de/api/interpreter")
-        query  { :data (overpass lat long zoom) }]
+        query  { :data o }]
     (tset r.headers ":method" "POST")
     (r:set_body (dict_to_query query))
-    (let [(headers stream) (r:go)
+    (let [(headers stream) (r:go)]
-          (tx ty) (latlon->tile lat long zoom)
+      (if (= (headers:get  ":status") "429")
-          data (json.decode (stream:get_body_as_string))]
+          nil
-      (canvas data.elements (math.floor tx) (math.floor ty)))))
+          (stream:get_body_as_string)))))
 
-{ : polylines }
+;; if we have json in disk, return it
+;; if we have an empty file on disk, that signifies a request in
+;;   flight, so return a "pending" sentinel
+;; if we have no disk file, kick off a request and send "pending" sentinel
+
+;; we'd like to have a way for completed background fetch to signal
+;; so that the map can be redrawn
+
+(fn polylines [cq x y zoom]
+  (let [k (..  x "_" y "_" zoom)
+        pathname (.. "/tmp/tiles/" k ".json")]
+    (if (file-exists? pathname)
+        (let [data (with-open [i (io.open pathname :r)] (i:read "*a"))]
+          (if (= data "")
+              []
+              (canvas (. (json.decode data) :elements) zoom)))
+        (let [out (io.open pathname :w)]
+          (cq:wrap (fn []
+                     (print "getting " k)
+                     (var json nil)
+                     (with-open [f out]
+                       (while (not json)
+                         (set json (unparsed-for-xyz x y zoom))
+                         (when (not json)
+                           (print "sleeping " k)
+                           (cqueues.sleep (math.random 2 6))))
+                       (print "got " k)
+                       (f:write json)
+                       true)))
+          [] ; return no lines for now
+          ))))
+
+
+
+
+
+{ : polylines : latlon->tile }