~jl2/cl-h3

c56717579229e9d14ae77fab076d13c2d5713b35 — Jeremiah LaRocco 9 months ago bee8415 master
Assorted changes.

* More tests
* #'grid-disks-unsafe
* #'show-decoded-h3-index
* #'d2r, #'r2d
5 files changed, 273 insertions(+), 7 deletions(-)

M cl-h3.lisp
M cl-h3.test.asd
M package.lisp
A t/h3.lisp
M t/package.lisp
M cl-h3.lisp => cl-h3.lisp +82 -5
@@ 17,6 17,32 @@

(in-package :cl-h3)

(defun extract (num pos len)
  (loop
    for i below len
    summing (ash (if (logbitp (+ pos i) num) 1 0) i)))

(defun show-decoded-h3-index (idx &optional (stream t))
  (flet ((show-field-data (name offset bits)
           (let ((value (extract idx offset bits)))
             (format stream "~(~16,a~): ~8d 0x~2,'0x b~8,'0b~%" name value value value))))
    (let ((fields '((:reserved #16r3f 1)
                    (:mode #16r3b 4)
                    (:mode-data #16r38 3)
                    (:resolution  #16r34 4)
                    (:base-cell #16r2d 8)))
          (first-digit-offset #16r2a))
      (loop
        for (name offset bits) in fields
        do
           (show-field-data name offset bits))
      (loop
        for i from 1
        for digit-offset from first-digit-offset downto 0 by 3
        do
           (show-field-data (format nil "digit-~a" i)
                            digit-offset
                            3)))))

(setf (symbol-function 'lat) #'car)



@@ 27,6 53,22 @@
(setf (symbol-function 'degs-to-rads) #'clh3i::degs-to-rads)
(setf (symbol-function 'rads-to-degs) #'clh3i::rads-to-degs)

(defgeneric r2d (radians))
(defmethod r2d ((radians number))
  (/ (* 180 radians) pi))

(defmethod r2d ((radians cons))
  (h3:lat-lng (r2d (car radians))
              (r2d (cdr radians))))

(defgeneric d2r (degrees))
(defmethod d2r ((degrees number))
  (/ (* pi degrees) 180))

(defmethod d2r ((degrees cons))
  (h3:lat-lng (d2r (car degrees))
              (d2r (cdr degrees))))

(setf (symbol-function 'cell-area-m2) #'clh3i::cell-area-m2)
(setf (symbol-function 'cell-area-km2) #'clh3i::cell-area-km2)
(setf (symbol-function 'cell-area-rads2) #'clh3i::cell-area-rads2)


@@ 284,6 326,30 @@
        when (not (zerop cell))
          collect cell))))

(defun grid-disks-unsafe (h3set k)
  (let* ((in-size (length h3set))
         (max-neighbors (* in-size (max-grid-disk-size k))))
    (autowrap:with-many-alloc ((neighbors 'clh3i::h3index max-neighbors)
                               (ch3set 'clh3i::h3index in-size))
      (loop
        for i below in-size
        for offset = (* (cffi:foreign-type-size :uint64) i)
        for cell in h3set
        do
           (setf (cffi:mem-ref ch3set :uint64 offset) cell))
      (loop
        for i below max-neighbors
        do
           (setf (cffi:mem-ref neighbors :uint64 (* (cffi:foreign-type-size :uint64) i)) 0))

      (clh3i::grid-disks-unsafe ch3set in-size k neighbors)

      (loop
        for i below max-neighbors
        for neigh = (cffi:mem-ref neighbors :uint64 (* (cffi:foreign-type-size :uint64) i))
        when (not (zerop neigh))
          collect neigh))))

(defun grid-ring-unsafe (index k)
  (let ((max-cells (if (zerop k) 1 (* 6 k))))
    (autowrap:with-alloc (cells 'clh3i::h3index max-cells)


@@ 319,6 385,13 @@
    (clh3i::lat-lng-to-cell geo resolution index)
    (cffi:mem-ref index :uint64)))

(defun latlng-to-cell (latlng resolution)
  (autowrap:with-many-alloc ((geo 'clh3i::lat-lng)
                             (index 'clh3i::h3index))
    (setf (clh3i::lat-lng.lat geo) (lat latlng))
    (setf (clh3i::lat-lng.lng geo) (lng latlng))
    (clh3i::lat-lng-to-cell geo resolution index)
    (cffi:mem-ref index :uint64)))

(defun origin-to-directed-edges (origin)
  (let ((max-cells 6))


@@ 348,7 421,9 @@
      for lat = (car pt)
      for lng = (cdr pt)
      for offset = (* (autowrap:foreign-type-size 'clh3i::lat-lng) i)
      for lat-lng = (clh3i::make-lat-lng :ptr (cffi:inc-pointer (clh3i::geo-loop.verts (clh3i::geo-polygon.geoloop geo-polygon)) offset))
      for lat-lng = (clh3i::make-lat-lng :ptr (cffi:inc-pointer
                                               (clh3i::geo-loop.verts (clh3i::geo-polygon.geoloop geo-polygon))
                                               offset))
      do
         (setf (clh3i::lat-lng.lat lat-lng) lat)
         (setf (clh3i::lat-lng.lng lat-lng) lng))


@@ 360,18 435,20 @@
      for hole in poly-holes
      for offset = (* (autowrap:foreign-type-size 'clh3i::geo-loop) i)
      for loop-ptr = (autowrap:alloc 'clh3i::geo-loop 1)
      for hole-loop = (clh3i::make-geo-loop :ptr loop-ptr)
      do
         (setf (cffi:mem-ref (clh3i::geo-loop-ptr holes) :pointer offset) loop-ptr)
         (setf (clh3i::geo-loop.num-verts hole-loop) (length hole))
         (setf (clh3i::geo-loop.verts hole-loop) (autowrap:alloc 'clh3i::lat-lng (length hole)))
         (setf (clh3i::geo-loop.num-verts (autowrap:ptr loop-ptr)) (length hole))
         (setf (clh3i::geo-loop.verts (autowrap:ptr loop-ptr))
               (autowrap:alloc 'clh3i::lat-lng (length hole)))
         (loop
           for i below (length hole)
           for pt in hole
           for lat = (car pt)
           for lng = (cdr pt)
           for offset = (* (autowrap:foreign-type-size 'clh3i::lat-lng) i)
           for lat-lng = (clh3i::make-lat-lng :ptr (cffi:inc-pointer (clh3i::geo-loop.verts hole-loop) offset))
           for lat-lng = (clh3i::make-lat-lng
                          :ptr (cffi:inc-pointer
                                loop-ptr offset))
           do
              (setf (clh3i::lat-lng.lat lat-lng) lat)
              (setf (clh3i::lat-lng.lng lat-lng) lng)))

M cl-h3.test.asd => cl-h3.test.asd +2 -1
@@ 31,5 31,6 @@
                :components
                ((:file "package")
                 (:file "basic")
                 (:file "cells-edges"))))
                 (:file "cells-edges")
                 (:file "h3"))))
  :perform (test-op :after (op c) (eval (read-from-string "(every #'fiveam::TEST-PASSED-P (5am:run :cl-h3))"))))

M package.lisp => package.lisp +7 -0
@@ 21,6 21,11 @@

  (:use #:cl #:j-utils #:alexandria)
  (:export
   #:show-decoded-h3-index

   #:d2r
   #:r2d

   #:h3-to-string
   #:lat-lng
   #:lat


@@ 63,6 68,7 @@
   #:get-resolution
   #:grid-disk
   #:grid-disk-distances
   #:grid-disks-unsafe
   #:grid-distance
   #:grid-path-cells
   #:grid-ring-unsafe


@@ 75,6 81,7 @@
   #:is-valid-directed-edge
   #:is-valid-vertex
   #:lat-lng-to-cell
   #:latlng-to-cell
   #:max-grid-disk-size
   #:origin-to-directed-edges
   #:polygon-to-cells

A t/h3.lisp => t/h3.lisp +171 -0
@@ 0,0 1,171 @@
(in-package :cl-h3.test)

(def-suite :h3-h3)
(in-suite :h3-h3)

(test is-valid
  (is (h3:is-valid-cell #16r85283473fffffff))
  (is (h3:is-valid-cell #16r850dab63fffffff))
  (is (h3:is-valid-cell #16r5004295803a88))
  (loop for res below 16 do
    (is (h3:is-valid-cell
         (h3:lat-lng-to-cell 37d0 -122d0 res)))))

(test geo-to-h3
  (is (=
       (h3:lat-lng-to-cell (h3:degs-to-rads 37.3615593d0)
                           (h3:degs-to-rads -122.0553238d0)
                           5)
       #16r85283473fffffff)))

(test get-resolution
  (loop
    for res below 16
    for cell = (h3:lat-lng-to-cell (h3:degs-to-rads 37.3615593d0)
                                   (h3:degs-to-rads -122.0553238d0)
                                   res)
    do
       (is (= (h3:get-resolution cell)
              res))))

(test silly-geo-to-h3
  (let* ((lat (h3:degs-to-rads 37.3615593d0))
         (lng (h3:degs-to-rads -122.0553238d0))
         (lat-plus-pi (+ pi lat))
         (lng-plus-2pi (+ pi pi lng))
         (expected-1 #16r85283473fffffff)
         (expected-2 #16r85ca2d53fffffff))
    (is (= (h3:lat-lng-to-cell lat lng 5)
           expected-1))
    (is (= (h3:lat-lng-to-cell lat-plus-pi lng-plus-2pi 5)
           expected-2))))

(test h3-to-geo
  (let ((lat (h3:degs-to-rads 37.34579337536848d0))
        (lng (h3:degs-to-rads -121.97637597255124d0))
        (res (h3:cell-to-lat-lng #16r85283473fffffff)))
    (is (fnear lat (h3:lat res)))
    (is (fnear lng (h3:lng res)))))

(test h3-to-geo-boundary
  (let ((actual (h3:cell-to-boundary #16r85283473fffffff))
        (expected (mapcar #'h3:d2r
                          '((37.271355866731895d0 . -121.91508032705622d0)
                            (37.353926450852256d0 . -121.86222328902491d0)
                            (37.42834118609435d0 . -121.9235499963016d0)
                            (37.42012867767778d0 . -122.0377349642703d0)
                            (37.33755608435298d0 . -122.09042892904395d0)
                            (37.26319797461824d0 . -122.02910130919d0)))))
    (is (= (length expected) (length actual)))
    (loop
      for act in actual
      for exp in expected
      do
         (is (fnear exp act)))))

(test k-ring-1
  (let* ((hex #16r8928308280fffff)
         (actual (sort (h3:grid-disk hex 1) #'<)))
    (is (= 7 (length actual)))
    (is (equal actual
               (sort (list #16r8928308280bffff
                 #16r89283082807ffff
                 #16r89283082877ffff
                 #16r8928308280fffff
                 #16r89283082803ffff
                 #16r89283082873ffff
                 #16r8928308283bffff)
                     #'<)))))

(test k-ring-2
  (let* ((hex #16r8928308280fffff)
         (actual (sort (h3:grid-disk hex 2) #'<)))
    (is (= (+ 1 6 12) (length actual)))
    (is (equal
         (sort (list
                #16r89283082813ffff
                #16r89283082817ffff
                #16r8928308281bffff
                #16r89283082863ffff
                #16r89283082823ffff
                #16r89283082873ffff
                #16r89283082877ffff
                #16r8928308280fffff
                #16r8928308287bffff
                #16r89283082833ffff
                #16r8928308282bffff
                #16r8928308283bffff
                #16r89283082857ffff
                #16r892830828abffff
                #16r89283082847ffff
                #16r89283082867ffff
                #16r89283082803ffff
                #16r89283082807ffff
                #16r8928308280bffff
                )
               #'<)
         actual))))

(test k-ring-pentagon
  (let* ((hex #16r821c07fffffffff)
         (actual (sort (h3:grid-disk hex 1) #'<)))
    (is (= (+ 1 5) (length actual)))
    (is (equal
         (sort (list
                #16r821c2ffffffffff
                #16r821c27fffffffff
                #16r821c07fffffffff
                #16r821c17fffffffff
                #16r821c1ffffffffff
                #16r821c37fffffffff
                )
               #'<)
         actual))))

(test k-ring-distance
  (let* ((hex #16r8928308280fffff)
         (actual (sort (h3:grid-disk-distances hex 1) #'< :key #'car)))
    (is (= (+ 1 6) (length actual)))
    (is (equal
         (sort (list
                '(#16r8928308280fffff . 0)
                '(#16r8928308280bffff . 1)
                '(#16r89283082807ffff . 1)
                '(#16r89283082877ffff . 1)
                '(#16r89283082803ffff . 1)
                '(#16r89283082873ffff . 1)
                '(#16r8928308283bffff . 1))
               #'<
               :key #'car)
         actual))))

(test polyfill
  (is (> (length (h3:polygon-to-cells
                  (mapcar #'h3:d2r
                          '(
                            (37.8133189999832380d0 . -122.4089866999972145d0)
                            (37.7866302000007224d0 . -122.3805436999997056d0)
                            (37.7198061999978478d0 . -122.3544736999993603d0)
                            (37.7076131999975672d0 . -122.5123436999983966d0)
                            (37.7835871999971715d0 . -122.5247187000021967d0)
                            (37.8151571999998453d0 . -122.4798767000009000d0)
                            ))
                  9))
         1000)))

(test polyfill-with-hole
      (is (> (length
              (h3:polygon-to-cells
               (mapcar #'h3:d2r
                       '((37.813318999983238 . -122.4089866999972145)
                         (37.7866302000007224 . -122.3805436999997056)
                         (37.7198061999978478 . -122.3544736999993603)
                         (37.7076131999975672 . -122.5123436999983966)
                         (37.7835871999971715 . -122.5247187000021967)
                         (37.8151571999998453 . -122.4798767000009008)))
               9
               (mapcar #'h3:d2r'((37.7869802 . -122.4471197)
                                 (37.7664102 . -122.4590777)
                                 (37.7710682 . -122.4137097)))))
             1000)))
              

M t/package.lisp => t/package.lisp +11 -1
@@ 24,9 24,19 @@

(in-package :cl-h3.test)

(defun fnear (a b &optional (eps 0.0001))
(defgeneric fnear (a b &optional eps))

(defmethod fnear ((a number) (b number) &optional (eps 0.0001))
  (< (abs (- b a)) eps))

(defmethod fnear ((a cons) (b cons) &optional (eps 0.0001))
  (and (fnear (car a) (car b) eps)
       (fnear (cdr a) (cdr b) eps)))

(defmethod r2d ((radians cons))
  (h3:lat-lng (r2d (car radians))
              (r2d (cdr radians))))

(def-suite :h3-old-tests)
(in-suite :h3-old-tests)