add compass rose

this is still not correct, but it's closer

pkgs/maps/default.nix

@@ -67,7 +67,6 @@ in stdenv.mkDerivation {
   ];
   GIO_EXTRA_MODULES = [ "${glib-networking.out}/lib/gio/modules" ];
   RXI_JSON="${rxi-json}/";
-  CAIRO_TRACE_SO = "${cairo.out}/lib/cairo/libcairo-trace.so";
 
   makeFlags = [ "PREFIX=${placeholder "out"}" "NAME=${pname}" ];
 

pkgs/maps/main.fnl

@@ -1,6 +1,5 @@
 ; (local { : view } (require :fennel))
 (local { : fdopen } (require :posix.stdio))
-(local ptime (require :posix.time))
 (local cqueues (require :cqueues))
 
 (local nmea (require :nmea))
@@ -8,21 +7,6 @@
 
 (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
@@ -62,17 +46,13 @@ label.readout {
      )
     (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
+                           :on_destroy Gtk.main_quit
                            }))
 
 (local state-widgets { })
@@ -86,8 +66,7 @@ label.readout {
             :lon 0
             :zoom 17
             :course 0 ; direction of travel
-            :orientation-target 0  ; map rotation angle from north
+            :orientation {:target 0 :actual 0} ; map rotation angle from north
-            :orientation-actual 0  ; map rotation angle from north
             :tiles {}
             }
  )
@@ -134,23 +113,17 @@ label.readout {
               :x (* tile-size num-tiles-x)
               :y (* tile-size num-tiles-y)
               }
-     :centre {
-              :x (/ (+ min-tile-x max-tile-x 1) 2)
-              :y (/ (+ min-tile-y max-tile-y 1) 2)
-              }
      }))
 
 ;; 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})
+  (expect= bounds.max {:x 65541 :y 45016}))
-  (expect= bounds.centre {:x 65539.5 :y 45014.5}))
 
 (let [bounds (map-bounds-tile 65539.0 45014.0)]
   (expect= bounds.min {:x 65536 :y 45011})
   (expect= bounds.max {:x 65541 :y 45016})
-  (expect= bounds.centre {:x 65539 :y 45014})
   )
 
 (fn map-bounds [lat lon zoom]
@@ -165,38 +138,66 @@ label.readout {
 
 (local cq (cqueues.new))
 
-(fn road-width-for [line]
+(fn road-width-for [line offset]
-  (case (?. line :tags :highway)
+  (+ (or offset 0)
-    :motorway 18
+     (case (?. line :tags :highway)
-    :trunk 17
+       :motorway 18
-    :primary 16
+       :trunk 17
-    :secondary 14
+       :primary 16
-    :cycleway 4
+       :secondary 14
-    :footway 4
+       :cycleway 4
-    other 12))
+       :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-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)
+  (let [road-width 14]
-  (each [_ line (pairs lines)]
+    (g:set_source_rgb 0 0 0)
-    (g:set_line_width (road-width-for line))
+    (each [_ line (pairs lines)]
-    (cairo-road-path g line.points bounds )
+      (cairo-road-path g line.points bounds (road-width-for line)))
-    (g:stroke))
+    (g:set_source_rgb 1 1 1)
-  (g:set_source_rgb 1 1 1)
+    (each [_ line (pairs lines)]
-  (each [_ line (pairs lines)]
+      (cairo-road-path g line.points bounds (road-width-for line -2)))))
-    (g:set_line_width (- (road-width-for line) 2))
-    (cairo-road-path g line.points bounds)
-    (g:stroke)))
 
+(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))
+        screen-angle (- angle
+                        (/ (* app-state.orientation.target math.pi) 180))]
+    (if (< (math.abs screen-angle) (/ math.pi 2))
+        (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)
 
@@ -223,32 +224,34 @@ label.readout {
       (g:rectangle 0 0 bounds.pixels.x bounds.pixels.y)
       (g:fill)
 
-      (g:translate (+ (// bounds.pixels.x 2))  (+ (// bounds.pixels.y 2)))
-      (g:rotate (* (/ (- app-state.orientation-target) 180) math.pi))
-      (g:translate (- (// bounds.pixels.x 2))  (- (// bounds.pixels.y 2)))
-
       (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
+          n (let [(x y angle) (label-coords line bounds)
-                  ext (g:text_extents n)
+                  ext  (g:text_extents n)
                   w ext.width
                   h ext.height]
-              (when (and tx ty (not (. seen-road-names n)))
+              (when (and x y (not (. seen-road-names n)))
-                (let [x (* tile-size (- tx bounds.min.x))
+                (tset seen-road-names n true)
-                      y (* tile-size (- ty bounds.min.y))]
+                (g:save)
-                  (tset seen-road-names n true)
+                (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:save)
-                  (g:move_to x y)
+                (g:move_to x y)
-                  (g:rotate angle)
+                (g:rotate angle)
-                  (g:rel_move_to (- (// w 2)) 3)
+                (g:rel_move_to 0 3)
-                  (g:text_path n)
+                (g:text_path n)
-                  (g:fill)
+                (g:fill)
-                  (g:restore))))))
+                (g:restore)))))
 
       surface)))
 
@@ -256,16 +259,8 @@ label.readout {
 (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 (/ (- viewport-width bounds.pixels.x) 2)
+        offset-x (- (* tile-size (- tile-x bounds.min.x)) (/ viewport-width 2))
-        offset-y (/ (- viewport-height bounds.pixels.y) 2)
+        offset-y (- (* tile-size (- tile-y bounds.min.y)) (/ viewport-height 2))]
-        x-to-centre (- tile-x bounds.centre.x)
-        y-to-centre (- tile-y bounds.centre.y)
-        angle (- (/ (* math.pi app-state.orientation-target) 180))
-        x-to-centre-rot (- (* x-to-centre (math.cos angle))
-                           (* y-to-centre (math.sin angle)))
-        y-to-centre-rot (+ (* x-to-centre (math.sin angle))
-                           (* y-to-centre (math.cos angle)))
-        ]
 
     (when (not map-surface)
       (let [window (widget:get_window)]
@@ -277,16 +272,11 @@ label.readout {
                   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)))
 
-    (when (not (= app-state.orientation-actual app-state.orientation-target))
+    (g:set_source_surface map-surface (- offset-x) (- offset-y))
-      (print (- app-state.orientation-actual app-state.orientation-target))
-      (g:translate (+ (/ viewport-width 2))  (+ (/ viewport-height 2)))
-      (g:rotate (* (/ (- 360 (- app-state.orientation-actual app-state.orientation-target)) 180) math.pi))
-      (g:translate (- (/ viewport-width 2))  (- (/ viewport-height 2))))
-
-    (g:set_source_surface map-surface
-                          (- offset-x (* tile-size x-to-centre-rot))
-                          (- offset-y (* tile-size y-to-centre-rot)))
     (g:set_operator cairo.Operator.SOURCE)
     (g:paint)))
 
@@ -324,15 +314,9 @@ label.readout {
 
 (expect= (hhmmss (+ 45 (* 60 12) (* 60 60 3))) "3:12:45")
 
-(fn turn-smoothly [from to]
-  (if (< (math.abs (- from to)) 10) to
-      (+ from (* 0.05 (- to from)))))
-
-
 
 (fn update-app-state [new-vals]
-  (let [old-state (merge {} app-state)
+  (let [old-bounds
-        old-bounds
         (map-bounds app-state.lat app-state.lon app-state.zoom)]
     (merge app-state new-vals)
     (let [bounds
@@ -340,27 +324,20 @@ label.readout {
       (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)
-    (when (> (math.abs (- app-state.orientation-target app-state.course)) 20)
+      (set app-state.orientation.target app-state.course)
-      (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))
+    (when (not (= app-state.orientation.target app-state.orientation.actual))
-      (set app-state.orientation-actual
+      (set app-state.orientation.actual 
-           (turn-smoothly app-state.orientation-actual app-state.orientation-target)))
+           (+ 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
+        :osm (: (widget:get_window) :invalidate_rect nil)
-        (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
@@ -391,7 +368,7 @@ label.readout {
                  (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)
+                   (g:rotate (* (/ (- app-state.course app-state.orientation.actual)
                                    180) math.pi))
                    (g:translate (// height -2) (// height -2))
                    (g:set_line_width 4)
@@ -423,7 +400,7 @@ label.readout {
                    (g:stroke)
                    
                    (g:translate (// height 2) (// height 2))
-                   (g:rotate (- (deg->rad app-state.orientation-actual)))
+                   (g:rotate (- (deg->rad app-state.orientation.actual)))
                    (g:translate (// height -2) (// height -2))
                    
                    (g:set_line_width 2)
@@ -495,15 +472,6 @@ label.readout {
    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))
@@ -514,5 +482,4 @@ label.readout {
 
 (window:show_all)
 (styles)
-(when (os.getenv "MAP_PROFILE") (collect-profile))
 (Gtk:main)

pkgs/maps/shell.nix

@@ -16,34 +16,13 @@ let
       };
     };
   fennel-ls = pkgs.fennel-ls.override { inherit (package) lua luaPackages; };
-  luaProfiler =
-    let
-      inherit (pkgs) stdenv cmake;
-      inherit (package) lua;
-    in stdenv.mkDerivation {
-      name = "LuaProfiler";
-      src = fetchFromGitHub {
-        owner = "Patrick08T";
-        repo = "LuaProfiler";
-        rev = "abb989337f6f46b820c9d2eb1e1d339e8f6f3760";
-        hash = "sha256-43kwZCZZmWD5ens1qCzD7LTg/jKMfcb9Vw/DBiN2sSo=";
-      };
-      buildInputs = [ lua ];
-      installPhase = ''
-        mkdir -p "$out/lib/lua/${lua.luaversion}"
-        echo cp /build/source/bin/release/libluaperf.so "$out/lib/lua/${lua.luaversion}"
-        cp /build/source/bin/release/libluaperf.so "$out/lib/lua/${lua.luaversion}"
-      '';
-      nativeBuildInputs = [ cmake ];
-    };
 in
 package.overrideAttrs(o: {
-  nativeBuildInputs = [ fennel-ls luaProfiler flamegraph  ] ++ o.nativeBuildInputs;
+  nativeBuildInputs = [ fennel-ls ] ++ o.nativeBuildInputs;
   shellHook = ''
     mkdir -p bin
     ( cd bin && ln -sf `type -p fennel-ls` `type -p fennel` . )
-    export LUA_CPATH=$(lua -e "print(package.cpath)")\;${luaProfiler}/lib/lua/${package.lua.luaversion}/\?.so
+    export LUA_CPATH=$(lua -e "print(package.cpath)")
     export LUA_PATH=$(lua -e "print(package.path)")\;$RXI_JSON/share/lua/5.3/?.lua
-
   '';
 })

pkgs/maps/tiles.fnl

@@ -59,24 +59,6 @@
       ]
      (table.concat  "\n"))))
 
-(fn label-coords [points]
-  (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))]
-    [(/ (+ nx x) 2) (/ (+ ny y) 2) angle]))
-
-
 (fn canvas [elements zoom]
   (let [nodes {}
         lines {}]
@@ -84,21 +66,19 @@
       (case e.type
         :node (tset nodes e.id e)
         :way
-        (let [points
+        (tset
-              (icollect [_ nd (ipairs e.nodes)]
+         lines
-                (let [node (. nodes nd)
+         e.id
-                      (tx ty) (latlon->tile node.lat node.lon zoom)]
+         {
-                  ;;(print e.tags.name e.id e.name node.lat node.lon)
+          :name (?. e :tags :name)
-                  [ tx ty  ]))]
+          :tags e.tags
-          (tset
+          :points
-           lines
+          (icollect [_ nd (ipairs e.nodes)]
-           e.id
+            (let [node (. nodes nd)
-           {
+                  (tx ty) (latlon->tile node.lat node.lon zoom)]
-            :name (?. e :tags :name)
+              ;;(print e.tags.name e.id e.name node.lat node.lon)
-            :tags e.tags
+              [ tx ty  ]))
-            :label-place (label-coords points)
+          })))
-            : points
-            }))))
     lines))