Skip to content
Snippets Groups Projects
Commit 1b3e9a92 authored by David Byers's avatar David Byers
Browse files

Merge branch '3-improve-performance-of-olc-is-functions' into 'master' 

Resolve "Improve performance of olc-is functions"

Closes #3

See merge request !4
parents 9a4d1985 45c94c3a
Branches
Tags 1.0.1
1 merge request!4Resolve "Improve performance of olc-is functions"
Hide whitespace changes
Inline Side-by-side
CHANGELOG
+ 11
− 0
View file @ 1b3e9a92
2020-07-23 David Byers <david.byers@liu.se> 2020-07-23 David Byers <david.byers@liu.se>
Fix issue #3:
* olc.el (olc-parse-code): Save match data.
(olc-is-valid): Save match data.
(olc-shorten-compound): Save match data.
(olc-recover-compound): Save match data.
(olc-is-valid): Rewrote as string operations.
(olc-value-mapping): Changed to defconst.
(olc-digit-mapping): Changed to defconst.
(olc-is-short): Operate on string.
(olc-is-full): Operate on string.
Fix issue #1 more properly: Fix issue #1 more properly:
* olc.el (olc-recover): Honor format arg when dealing with full * olc.el (olc-recover): Honor format arg when dealing with full
codes. codes.
......
Makefile
+ 4
− 2
View file @ 1b3e9a92
...@@ -25,6 +25,7 @@ all: olc.elc olc.info ...@@ -25,6 +25,7 @@ all: olc.elc olc.info
check: check:
emacs --batch \ emacs --batch \
--eval "(setq-default indent-tabs-mode nil)" \ --eval "(setq-default indent-tabs-mode nil)" \
--eval "(setq-default fill-column 79)" \
-f package-initialize \ -f package-initialize \
-l elisp-lint \ -l elisp-lint \
-f elisp-lint-files-batch \ -f elisp-lint-files-batch \
...@@ -42,8 +43,9 @@ olc.info: olc.texi ...@@ -42,8 +43,9 @@ olc.info: olc.texi
.PHONY: test .PHONY: test
test: test:
( cd test && \ ( cd test && \
emacs -batch \ emacs --batch \
-f package-initialize \ -f package-initialize \
-l ../olc.el \ -l ../olc.el \
-l olctest.el \ -l olctest.el \
-f olctest-batch-test ) -f olctest-batch-test \
)
olc.el
+ 225
− 189
View file @ 1b3e9a92
...@@ -72,10 +72,10 @@ ...@@ -72,10 +72,10 @@
;;; Base 20 digits: ;;; Base 20 digits:
(defvar olc-value-mapping "23456789CFGHJMPQRVWX" (defconst olc-value-mapping "23456789CFGHJMPQRVWX"
"Mapping from values to olc base 20 digits.") "Mapping from values to olc base 20 digits.")
(defvar olc-digit-mapping (defconst olc-digit-mapping
(let ((count 0)) (let ((count 0))
(mapcan (lambda (letter) (mapcan (lambda (letter)
(prog1 (list (cons letter count) (prog1 (list (cons letter count)
...@@ -169,119 +169,151 @@ raise, and args for the raised error. ...@@ -169,119 +169,151 @@ raise, and args for the raised error.
"Parse an open location code CODE." "Parse an open location code CODE."
(if (olc-parse-p code) (if (olc-parse-p code)
code code
(let ((pos 0) (save-match-data
(pairs nil) (let ((pos 0)
(short nil) (pairs nil)
(precision nil) (short nil)
(grid nil) (precision nil)
(padding 0)) (grid nil)
(padding 0))
;; Parse up to four initial pairs
(catch 'break ;; Parse up to four initial pairs
(while (< pos (length code)) (catch 'break
(olc-transform-error (while (< pos (length code))
(args-out-of-range olc-parse-error (olc-transform-error
"code too short" code (1+ pos)) (args-out-of-range olc-parse-error
(cond ((eq (elt code pos) ?+) (throw 'break nil)) "code too short" code (1+ pos))
((eq (elt code pos) ?0) (throw 'break nil)) (cond ((eq (elt code pos) ?+) (throw 'break nil))
((= (length pairs) 4) (throw 'break nil)) ((eq (elt code pos) ?0) (throw 'break nil))
((not (olc-valid-char (elt code pos))) ((= (length pairs) 4) (throw 'break nil))
(signal 'olc-parse-error ((not (olc-valid-char (elt code pos)))
(list "invalid character" pos code))) (signal 'olc-parse-error
((not (olc-valid-char (elt code (1+ pos)))) (list "invalid character" pos code)))
(signal 'olc-parse-error ((not (olc-valid-char (elt code (1+ pos))))
(list "invalid character" (1+ pos) code))) (signal 'olc-parse-error
(t (setq pairs (cons (cons (elt code pos) (list "invalid character" (1+ pos) code)))
(elt code (1+ pos))) (t (setq pairs (cons (cons (elt code pos)
pairs))))) (elt code (1+ pos)))
(setq pos (+ pos 2)))) pairs)))))
(setq pos (+ pos 2))))
;; Measure the padding
(when (string-match "0+" code pos) ;; Measure the padding
(setq pos (match-end 0) (when (string-match "0+" code pos)
padding (- (match-end 0) (match-beginning 0)))) (setq pos (match-end 0)
padding (- (match-end 0) (match-beginning 0))))
;; Parse the separator
(olc-transform-error ;; Parse the separator
(args-out-of-range olc-parse-error (olc-transform-error
"code too short" code pos) (args-out-of-range olc-parse-error
(if (eq (elt code pos) ?+) "code too short" code pos)
(setq pos (1+ pos)) (if (eq (elt code pos) ?+)
(setq pos (1+ pos))
(signal 'olc-parse-error
(list "missing separator" pos code))))
;; Check the length of the padding
(unless (and (= (% padding 2) 0)
(<= (+ padding (* 2 (length pairs))) 8))
(signal 'olc-parse-error (signal 'olc-parse-error
(list "missing separator" pos code)))) (list "incorrect padding length" pos code)))
;; Check the length of the padding ;; Determine if the code is shortened or not
(unless (and (= (% padding 2) 0) (setq short (< (+ (* 2 (length pairs)) padding) 8))
(<= (+ padding (* 2 (length pairs))) 8))
(signal 'olc-parse-error
(list "incorrect padding length" pos code)))
;; Determine if the code is shortened or not ;; We cant be short and have padding (not sure why)
(setq short (< (+ (* 2 (length pairs)) padding) 8)) (when (and short (> padding 0))
(signal 'olc-parse-error
(list "padded codes can't be shortened" pos code)))
;; We cant be short and have padding (not sure why) ;; Determine the precision of the code
(when (and short (> padding 0)) (setq precision (- 8 padding))
(signal 'olc-parse-error
(list "padded codes can't be shortened" pos code)))
;; Determine the precision of the code ;; Parse what's after the separator
(setq precision (- 8 padding)) (when (< pos (length code))
(when (> padding 0)
(signal 'olc-parse-error
(list "padding followed by data" pos code)))
;; Parse what's after the separator ;; Parse one more pair
(when (< pos (length code)) (olc-transform-error
(when (> padding 0) (args-out-of-range olc-parse-error
(signal 'olc-parse-error "code too short" code (1+ pos))
(list "padding followed by data" pos code))) (setq pairs (cons (cons (elt code pos)
(elt code (1+ pos)))
pairs)
pos (+ 2 pos)
precision (+ 2 precision)))
;; Parse grid
(while (< pos (length code))
(cond ((not (olc-valid-char (elt code pos)))
(signal 'olc-parse-error
(list "invalid character" pos code)))
((>= (length grid) 5) (setq pos (1+ pos)))
(t (setq grid (cons (elt code pos) grid)
pos (1+ pos)
precision (1+ precision))))))
;; Parse one more pair ;; Check for an empty code
(olc-transform-error (unless pairs
(args-out-of-range olc-parse-error (signal 'olc-parse-error (list "invalid code" 0 code)))
"code too short" code (1+ pos))
(setq pairs (cons (cons (elt code pos) ;; Return the result
(elt code (1+ pos))) (olc-parse-create :pairs (nreverse pairs)
pairs) :grid (nreverse grid)
pos (+ 2 pos) :short short
precision (+ 2 precision))) :precision precision)))))
;; Parse grid
(while (< pos (length code))
(cond ((not (olc-valid-char (elt code pos)))
(signal 'olc-parse-error
(list "invalid character" pos code)))
((>= (length grid) 5) (setq pos (1+ pos)))
(t (setq grid (cons (elt code pos) grid)
pos (1+ pos)
precision (1+ precision))))))
;; Check for an empty code
(unless pairs
(signal 'olc-parse-error (list "invalid code" 0 code)))
;; Return the result
(olc-parse-create :pairs (nreverse pairs)
:grid (nreverse grid)
:short short
:precision precision))))
;;; Public functions: ;;; Public functions:
(defconst olc-code-regexp (format "^\\([%s]*\\)\\(0*\\)\\+\\([%s]*\\)$"
olc-value-mapping
olc-value-mapping)
"Regular expression for parsing codes.")
(defun olc-is-valid (code) (defun olc-is-valid (code)
"Return non-nil if CODE is a valid open location code." "Return non-nil if CODE is a valid open location code."
(condition-case nil (or (olc-parse-p code)
(olc-parse-code code) (save-match-data
(olc-parse-error nil))) (let ((case-fold-search t))
;; The code is decomposed into PAIRS PADDING "+" SUFFIX.
;;
;; Rules:
;;
;; - For all codes:
;; - Pairs has an even (zero counts) length of at most 8.
;; - Suffix is either zero or between 2 and 8 characters.
;; - One or both of pairs and suffix must not be empty.
;;
;; - If there is padding:
;; - The suffix must be empty
;; - The length of pairs and padding combined must be 8
(when (string-match olc-code-regexp code)
(let ((pair-len (- (match-end 1) (match-beginning 1)))
(padd-len (- (match-end 2) (match-beginning 2)))
(suff-len (- (match-end 3) (match-beginning 3))))
(and (and (= 0 (% pair-len 2)) (<= pair-len 8)) ; Check pairs
(and (<= suff-len 8) (/= suff-len 1)) ; Check suffix
(> (+ pair-len suff-len) 0) ; Check for not empty
(or (= padd-len 0) ; Empty padding...
(and (= suff-len 0) ; ...or suffix
(= (+ padd-len pair-len) 8))))))))))
(defun olc-is-short (code) (defun olc-is-short (code)
"Return non-nil if CODE is a valid short open location code. "Return non-nil if CODE is a valid short open location code.
Note that nil means the code is either not short, or it is Note that nil means the code is either not short, or it is
invalid." invalid."
(condition-case nil (if (olc-parse-p code)
(olc-parse-short (olc-parse-code code)) (olc-parse-short code)
(olc-parse-error nil))) (and (olc-is-valid code)
(or (< (length code) 9)
(and (>= (length code) 9)
(not (= (elt code 8) ?+)))))))
(defun olc-is-full (code) (defun olc-is-full (code)
...@@ -289,9 +321,11 @@ invalid." ...@@ -289,9 +321,11 @@ invalid."
Note that nil means the code is either not long, or it is Note that nil means the code is either not long, or it is
invalid." invalid."
(condition-case nil (if (olc-parse-p code)
(not (olc-parse-short (olc-parse-code code))) (not (olc-parse-short code))
(olc-parse-error nil))) (and (olc-is-valid code)
(and (>= (length code) 9)
(= (elt code 8) ?+)))))
(defun olc-code-precision (code) (defun olc-code-precision (code)
...@@ -459,53 +493,54 @@ it can take some time to complete. If you can set the zoom level ...@@ -459,53 +493,54 @@ it can take some time to complete. If you can set the zoom level
to a single number, then it will make one call only, and is much to a single number, then it will make one call only, and is much
faster. faster.
" "
(let* ((area (olc-decode code)) (save-match-data
(zoom-lo (cond ((numberp zoom) zoom) (let* ((area (olc-decode code))
((listp zoom) (elt zoom 0)) (zoom-lo (cond ((numberp zoom) zoom)
(t (signal 'args-out-of-range zoom)))) ((listp zoom) (elt zoom 0))
(zoom-hi (cond ((numberp zoom) (1+ zoom)) (t (signal 'args-out-of-range zoom))))
((listp zoom) (1+ (elt zoom 1))) (zoom-hi (cond ((numberp zoom) (1+ zoom))
(t (signal 'args-out-of-range zoom)))) ((listp zoom) (1+ (elt zoom 1)))
result) (t (signal 'args-out-of-range zoom))))
(catch 'result result)
(while (< zoom-lo zoom-hi) (catch 'result
(let* ((zoom (floor (+ zoom-lo zoom-hi) 2)) (while (< zoom-lo zoom-hi)
(resp (request-response-data (let* ((zoom (floor (+ zoom-lo zoom-hi) 2))
(request (resp (request-response-data
"https://nominatim.openstreetmap.org/reverse" (request
:params `((lat . ,(olc-area-lat area)) "https://nominatim.openstreetmap.org/reverse"
(lon . ,(olc-area-lon area)) :params `((lat . ,(olc-area-lat area))
(zoom . ,zoom) (lon . ,(olc-area-lon area))
(format . "json")) (zoom . ,zoom)
:parser #'json-read (format . "json"))
:sync t))) :parser #'json-read
(tmp-code :sync t)))
(when resp (tmp-code
(olc-shorten code (when resp
(string-to-number (olc-shorten code
(alist-get 'lat resp)) (string-to-number
(string-to-number (alist-get 'lat resp))
(alist-get 'lon resp)) (string-to-number
:limit limit))) (alist-get 'lon resp))
(padlen (when (string-match "+" tmp-code) :limit limit)))
(- 8 (match-beginning 0))))) (padlen (when (string-match "+" tmp-code)
(- 8 (match-beginning 0)))))
;; Keep the shortest code we see that has at most limit
;; chars removed ;; Keep the shortest code we see that has at most limit
(when (and (<= padlen limit) ;; chars removed
(or (null result) (when (and (<= padlen limit)
(< (length tmp-code) (length (car result))))) (or (null result)
(setq result (cons tmp-code (< (length tmp-code) (length (car result)))))
(alist-get 'display_name resp)))) (setq result (cons tmp-code
(alist-get 'display_name resp))))
;; Zoom in or out
(if (< padlen limit) ;; Zoom in or out
(setq zoom-lo (1+ zoom)) (if (< padlen limit)
(setq zoom-hi zoom)))) (setq zoom-lo (1+ zoom))
(if (and result (> 8 (progn (string-match "+" (car result)) (setq zoom-hi zoom))))
(match-end 0)))) (if (and result (> 8 (progn (string-match "+" (car result))
(concat (car result) " " (cdr result)) (match-end 0))))
code)))) (concat (car result) " " (cdr result))
code)))))
(cl-defun olc-recover (code lat lon &key (format 'area)) (cl-defun olc-recover (code lat lon &key (format 'area))
...@@ -561,51 +596,52 @@ not specified, the reference is assumed to be embedded into CODE. ...@@ -561,51 +596,52 @@ not specified, the reference is assumed to be embedded into CODE.
If FORMAT is `area' (or any other value), the returned value is an If FORMAT is `area' (or any other value), the returned value is an
full open location code." full open location code."
;; Make sure we can do requests ;; Make sure we can do requests
(unless (fboundp 'request) (signal 'void-function 'request)) (save-match-data
(unless (fboundp 'request) (signal 'void-function 'request))
;; Check types (defer check of ref)
(cl-check-type code stringp) ;; Check types (defer check of ref)
(cl-check-type format (member latlon area nil)) (cl-check-type code stringp)
(cl-check-type format (member latlon area nil))
;; Process code and check ref
(cond ((string-match "^\\(\\S-+\\)\\s-+\\(.*\\)$" code) ;; Process code and check ref
(progn (cl-check-type ref null) (cond ((string-match "^\\(\\S-+\\)\\s-+\\(.*\\)$" code)
(setq ref (match-string 2 code) (progn (cl-check-type ref null)
code (match-string 1 code)))) (setq ref (match-string 2 code)
((olc-is-full code)) code (match-string 1 code))))
(t (cl-check-type ref stringp))) ((olc-is-full code))
(t (cl-check-type ref stringp)))
;; If the code is full then return it
(if (olc-is-full code) ;; If the code is full then return it
(olc-recover code 0 0 :format format) (if (olc-is-full code)
(let ((resp (request "https://nominatim.openstreetmap.org/search" (olc-recover code 0 0 :format format)
:params `((q . ,ref) (let ((resp (request "https://nominatim.openstreetmap.org/search"
(format . "json") :params `((q . ,ref)
(limit . 1)) (format . "json")
:parser #'json-read (limit . 1))
:sync t))) :parser #'json-read
:sync t)))
;; Check that we got a response
(unless (eq 200 (request-response-status-code resp)) ;; Check that we got a response
(signal 'olc-recover-error (unless (eq 200 (request-response-status-code resp))
(list "error decoding reference"
(request-response-status-code resp))))
(let* ((data (elt (request-response-data resp) 0))
(lat (alist-get 'lat data))
(lon (alist-get 'lon data)))
;; Check that we have a lat and lon
(unless (and lat lon)
(signal 'olc-recover-error (signal 'olc-recover-error
(list "reference location missing lat or lon" (list "error decoding reference"
data))) (request-response-status-code resp))))
;; Finally recover the code! (let* ((data (elt (request-response-data resp) 0))
(olc-recover code (lat (alist-get 'lat data))
(string-to-number lat) (lon (alist-get 'lon data)))
(string-to-number lon)
:format format))))) ;; Check that we have a lat and lon
(unless (and lat lon)
(signal 'olc-recover-error
(list "reference location missing lat or lon"
data)))
;; Finally recover the code!
(olc-recover code
(string-to-number lat)
(string-to-number lon)
:format format))))))
(provide 'olc) (provide 'olc)
......
test/olctest.el
+ 49
− 25
View file @ 1b3e9a92
...@@ -62,6 +62,10 @@ ...@@ -62,6 +62,10 @@
(unless (string= exp act) (unless (string= exp act)
(olctest-record-failure :exp exp :act act :msg msg))) (olctest-record-failure :exp exp :act act :msg msg)))
(cl-defun olctest-float= (&key exp act msg)
(unless (< (abs (- act exp)) olctest-decode-tolerance)
(olctest-record-failure :exp exp :act act :msg msg)))
(cl-defun olctest-equal (&key exp act msg) (cl-defun olctest-equal (&key exp act msg)
(unless (equal exp act) (unless (equal exp act)
(olctest-record-failure :exp exp :act act :msg msg))) (olctest-record-failure :exp exp :act act :msg msg)))
...@@ -160,27 +164,27 @@ ...@@ -160,27 +164,27 @@
"Test decoding." "Test decoding."
(olctest-testcase "reference:decoding" (olctest-testcase "reference:decoding"
(olctest-run-csv ("decoding.csv" case) (olctest-run-csv ("decoding.csv" case)
(let ((area (olc-decode (alist-get 'code case))) (let* ((code (alist-get 'code case))
(exp-latlo (alist-get 'latLo case)) (parse (condition-case nil (olc-parse-code code) (error nil)))
(exp-lathi (alist-get 'latHi case)) (area (and parse (olc-decode parse)))
(exp-lonlo (alist-get 'lngLo case)) (exp-latlo (alist-get 'latLo case))
(exp-lonhi (alist-get 'lngHi case)) (exp-lathi (alist-get 'latHi case))
(exp-len (alist-get 'length case))) (exp-lonlo (alist-get 'lngLo case))
(unless (and (= exp-len (olc-code-precision (alist-get 'code case))) (exp-lonhi (alist-get 'lngHi case))
(< (abs (- (olc-area-latlo area) exp-latlo)) olctest-decode-tolerance) (exp-len (alist-get 'length case))
(< (abs (- (olc-area-lathi area) exp-lathi)) olctest-decode-tolerance) (lineno (alist-get 'lineno case))
(< (abs (- (olc-area-lonlo area) exp-lonlo)) olctest-decode-tolerance) (pact-len (and parse (olc-code-precision parse)))
(< (abs (- (olc-area-lonhi area) exp-lonhi)) olctest-decode-tolerance)) (sact-len (olc-code-precision code))
(olctest-record-failure (msg (format "%d:%s:%%s" lineno code)))
:exp (format "%d,%f,%f,%f,%f" exp-len exp-latlo exp-lonlo exp-lathi exp-lonhi) (if (null area)
:act (format "%d,%f,%f,%f,%f" (olctest-record-failure :exp 'success :act 'parse-error :msg code)
(olc-code-precision (alist-get 'code case)) (olctest-equal :act (olc-code-precision code) :exp exp-len :msg (format msg "len(string)"))
(olc-area-latlo area) (olctest-equal :act (olc-code-precision parse) :exp exp-len :msg (format msg "len(parsed)"))
(olc-area-lonlo area) (olctest-float= :act (olc-area-latlo area) :exp exp-latlo :msg (format msg "latlo"))
(olc-area-lathi area) (olctest-float= :act (olc-area-lathi area) :exp exp-lathi :msg (format msg "lathi"))
(olc-area-lonhi area)) (olctest-float= :act (olc-area-lonlo area) :exp exp-lonlo :msg (format msg "lonlo"))
:msg (alist-get 'lineno case))))))) (olctest-float= :act (olc-area-lonhi area) :exp exp-lonhi :msg (format msg "lonhi"))
)))))
(defun olctest-shortcodes () (defun olctest-shortcodes ()
"Test recovering." "Test recovering."
...@@ -211,13 +215,18 @@ ...@@ -211,13 +215,18 @@
(olctest-testcase "reference:validity" (olctest-testcase "reference:validity"
(olctest-run-csv ("validityTests.csv" case) (olctest-run-csv ("validityTests.csv" case)
(let* ((code (alist-get 'code case)) (let* ((code (alist-get 'code case))
(parse (condition-case nil (olc-parse-code code) (error nil)))
(exp (list (alist-get 'isValid case) (exp (list (alist-get 'isValid case)
(alist-get 'isShort case) (alist-get 'isShort case)
(alist-get 'isFull case))) (alist-get 'isFull case)))
(act (list (not (not (olc-is-valid code))) (sact (list (and parse (not (not (olc-is-valid code))))
(not (not (olc-is-short code))) (and parse (not (not (olc-is-short code))))
(not (not (olc-is-full code)))))) (and parse (not (not (olc-is-full code))))))
(olctest-equal :exp exp :act act :msg code))))) (pact (list (and parse (not (not (olc-is-valid parse))))
(and parse (not (not (olc-is-short parse))))
(and parse (not (not (olc-is-full parse)))))))
(olctest-equal :exp exp :act pact :msg (format "%s:parsed" code))
(olctest-equal :exp exp :act sact :msg (format "%s:string" code))))))
(defvar olctest-local-shorten-tests (defvar olctest-local-shorten-tests
...@@ -238,6 +247,20 @@ ...@@ -238,6 +247,20 @@
(olctest-string= :exp shortcode :act actual :msg len))))) (olctest-string= :exp shortcode :act actual :msg len)))))
(defun olctest-issue-3 ()
(olctest-testcase "local:issue-3"
(olctest-equal :exp nil
:act (olc-is-short "22334455+")
:msg "S1")
(olctest-equal :exp t
:act (olc-is-short "334455+66")
:msg "S2")
(olctest-equal :exp nil
:act (olc-is-short "+12345678")
:msg "S3")))
(defun olctest-issue-1 () (defun olctest-issue-1 ()
(olctest-testcase "local:issue-1" (olctest-testcase "local:issue-1"
(olctest-assert-error (:exp (wrong-type-argument) :msg "F1") (olctest-assert-error (:exp (wrong-type-argument) :msg "F1")
...@@ -286,6 +309,7 @@ ...@@ -286,6 +309,7 @@
(olctest-shortcodes) (olctest-shortcodes)
(olctest-validity) (olctest-validity)
(olctest-localtests) (olctest-localtests)
(olctest-issue-3)
(olctest-issue-1) (olctest-issue-1)
)) ))
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment