158 lines
4.5 KiB
Fennel
158 lines
4.5 KiB
Fennel
(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)))))
|
|
|
|
(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)))
|
|
|
|
(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)))
|
|
|
|
(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 (- ny y) (- nx x))]
|
|
[(/ (+ 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)]
|
|
;;(print e.tags.name e.id e.name node.lat node.lon)
|
|
[ 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 fetch [cq x y zoom cb]
|
|
(let [k (tile-name x y zoom)
|
|
pathname (.. "/tmp/tiles/" k ".json")]
|
|
(if (file-exists? pathname)
|
|
(let [payload (with-open [i (io.open pathname :r)] (i:read "*a"))]
|
|
(when (not (= payload ""))
|
|
(cb (canvas (. (json.decode payload) :elements) zoom))))
|
|
(let [out (io.open pathname :w)]
|
|
(cq:wrap (fn []
|
|
(print "getting " k)
|
|
(var payload nil)
|
|
(with-open [f out]
|
|
(while (not payload)
|
|
(set payload (unparsed-for-xyz x y zoom))
|
|
(when (not payload)
|
|
(print "sleeping " k)
|
|
(cqueues.sleep (math.random 2 6))))
|
|
(print "got " k)
|
|
(f:write payload)
|
|
(cb (canvas (. (json.decode payload) :elements) zoom))
|
|
true)))))))
|
|
|
|
{ : fetch : latlon->tile :name tile-name }
|