biscuit

tiles.fnl (4907B)

---

 (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))
 
 (local f% string.format)
 
 (fn sinh [x] (/ (- 1 (math.exp (* -2 x))) (* 2 (math.exp (- x)))))
 
 (define-tests :sinh
   (expect (< (math.abs  (- (sinh 2) 3.626860407847)) 0.001)))
 
 (fn tile->latlon [xtile ytile zoom]
   (let [n (^ 2 zoom)
         lon-deg (- (/ (* xtile 360) n) 180.0)
         lat-rad (math.atan
                  (sinh (* math.pi (- 1 (/ (* 2 ytile) n))))
                  )]
 
     (values (/ (* lat-rad 180) math.pi) lon-deg)))
 
 (define-tests
   :tile->latlon
   (let [(lat lon) (tile->latlon 0 0 0)]
     (expect= lon -180)
     (expect-near lat 85.05112877)
     )
 
   (let [(lat lon) (tile->latlon 232798 103246 18)]
     (expect-near lon 139.699401855)
     (expect-near lat 35.6595278648)
     ))
 
 (fn latlon->tile [lat lon zoom]
   (let [n (^ 2 zoom)
         x (* n (/ (+ lon 180) 360))
         t1 (/ (* lat math.pi) 180)
         t (math.log (+ (math.tan t1) (/ 1 (math.cos t1))))
         y (* (- 1 (/ t math.pi)) (/ n 2))]
     (values x y)))
 
 (define-tests :latlon->tile
   (let [(x y) (latlon->tile 52.1234 -0.53 17)]
     (expect= (math.floor x) 65343)
     (expect= (math.floor y) 43221)))
 
 
 (fn overpass [lat lon zoom]
   (let [width (/ 360 (^ 2 zoom))
         n lat
         w lon
         s (- lat width)
         e (+ lon width)]
     (->
      [
       "[out:json];"
       (f% "way(%f,%f,%f,%f)['highway'];" s w n e)
       "(._;>;);"
       "out;"
       ]
      (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 (- nx x) (- y ny))]
     [(/ (+ nx x) 2) (/ (+ ny y) 2) angle]))
 
 
 (fn canvas [elements zoom]
   (let [nodes {}
         lines {}]
     (each [_ e (ipairs elements)]
       (case e.type
         :node (tset nodes e.id e)
         :way
         (let [points
               (icollect [_ nd (ipairs e.nodes)]
                 (let [node (. nodes nd)
                       (tx ty) (latlon->tile node.lat node.lon zoom)]
                   [ tx ty ]))]
           (tset
            lines
            e.id
            {
             :name (?. e :tags :name)
             :tags e.tags
             :label-place (label-coords points)
             : points
             }))))
     lines))
 
 
 (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 o }]
     (tset r.headers ":method" "POST")
     (r:set_body (dict_to_query query))
     (let [(headers stream) (r:go)]
       (if (= (headers:get  ":status") "429")
           nil
           (stream:get_body_as_string)))))
 
 ;; 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 tile-name [x y zoom]
   (.. x "_" y "_" zoom))
 
 
 (fn tile-status- [x y zoom]
   (let [k (tile-name x y zoom)
         pathname (.. "/tmp/tiles/" k ".json")
         payload (match (io.open pathname :r)
                   f (with-open [i f] (i:read "*a"))
                   _ nil)
         (valid val) (if payload (pcall json.decode payload))]
     (if (or (= payload nil) (not valid))
         (values :missing pathname)
         (= payload "")
         (values :pending)
         valid
         (values :json val)
         true
         (values :unknown))))
 
 (fn tile-status [x y zoom]
   (let [(s v) (tile-status- x y zoom)]
     (values s v)))
 
 (fn fetch [cq x y zoom cb]
   (print "fetch" x y zoom)
   (case (tile-status x y zoom)
     (:pending) nil
     (:json val) (cb (canvas (. val :elements) zoom))
     (:missing pathname)
     (cq:wrap
      (fn []
        (print "getting " pathname)
        (var payload nil)
        (with-open [f (io.open pathname :w)]
          (while (not payload)
            (set payload (unparsed-for-xyz x y zoom))
            (when (not payload)
              (print "sleeping " pathname)
              (cqueues.sleep (math.random 2 6))))
          (print "got " pathname)
          (f:write payload))
        (fetch cq x y zoom cb)))))
 
 { : fetch : latlon->tile :name tile-name }