From: Matt Birkholz Date: Mon, 4 Nov 2013 21:05:56 +0000 (-0700) Subject: planetarium: Request 8 Google elevations at once. X-Git-Tag: mit-scheme-pucked-9.2.12~429 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5fefa917b757381235f2f6569ae644e17b95a6b9;p=mit-scheme.git planetarium: Request 8 Google elevations at once. --- diff --git a/src/planetarium/google-earth-requests.scm b/src/planetarium/google-earth-requests.scm index f9a796b59..f5a79d4c1 100644 --- a/src/planetarium/google-earth-requests.scm +++ b/src/planetarium/google-earth-requests.scm @@ -28,19 +28,24 @@ USA. ;; 2,500 requests per day. ;; 512 locations per request. ;; 25,000 total locations per day. +;; +;; URLs are restricted to 2048 characters. ;; The following procedure is intended to run as a cron job once a ;; minute (1440 requests per day) and log its progress to -;; ./monterey-bay.txt. +;; ./monterey-bay.txt. Each run makes one request for 8 elevations. +;; The job will get 11,520 elevations/day and take 0.89 days to fill a +;; 101x101 grid. (define (monterey-bay) ;; This procedure generates 10201 locations on a 101x101 grid ;; between 36,-122.5 and 37,-121.5 inclusive -- the coast and sea ;; floor of Monterey Bay. + (load-option 'xml) (if (not (file-exists? "monterey-bay.txt")) - (error "Could not find google-elevation-requests.txt.")) + (error "Could not find monterey-bay.txt")) (request-google-elevation (let ((longs (iota 101 -122.5 0.01)) - (lats (iota 101 36 0.01))) + (lats (iota 101 36. 0.01))) (append-map! (lambda (lat) (map (lambda (long) @@ -53,44 +58,93 @@ USA. (let ((data (read-elevation-data log-file)) (time (get-universal-time))) ;; Double-check request count. - (if (< 2500 (count-requests-after (- time (* 24 60 60)) data)) + (if (< 20000 (count-locations-after (- time (* 24 60 60)) data)) (error "Request allowance exceeded.")) ;; Send request. - (log-elevation (send-next-elevation-request locations data time) log-file))) + (log-elevations (send-next-elevation-request locations data time) + log-file))) (define (send-next-elevation-request locations data time) - (let* ((location (next-elevation-location locations data)) + (let* ((locations-per-request 8) + (request-locations + (list-head (remaining-locations locations data) + locations-per-request)) (url (string-append "http://maps.googleapis.com/maps/api/elevation/" "xml?sensor=false&locations=" - (number->string (latitude location)) - ","(number->string (longitude location)))) - (elev.res (reply-elevation.resolution - (let* ((port (open-input-gfile url)) - (reply (read-xml port))) - (close-input-port port) - reply)))) - (make-elevation (universal-time->global-time-string time) - (string-append (number->string (latitude location)) - ","(number->string (longitude location))) - (car elev.res) - (cdr elev.res)))) - -(define (next-elevation-location locations data) + (decorated-string-append + "" "%7C" "" + (map (lambda (location) + (string-append + (number->string (latitude location)) + ","(number->string (longitude location)))) + request-locations))))) + (let* ((port (open-input-gfile url) + #;(open-input-file "reply.txt")) + (reply (read-xml port))) + (close-input-port port) + (let ((root (xml-document-root reply))) + (if (not (eq? '|ElevationResponse| (xml-element-name root))) + (error "Bogus reply:" (xml->string reply))) + (let ((root-content (xml-element-content root))) + ;; First element: status OK + (let ((first (skip-strings root-content))) + (let ((element (and (pair? first) (car first)))) + (if (not (and (eq? '|status| (xml-element-name element)) + (string=? "OK" (get-content element)))) + (error "Status not OK:" (xml->string reply)))) + ;; Rest: with and . + (let loop ((next (and (pair? first) (skip-strings (cdr first)))) + (elevations '())) + (if (null? next) + (reverse! elevations) + (let ((result (car next))) + (if (not (eq? '|result| (xml-element-name result))) + (error "Non-result:" result)) + (loop (skip-strings (cdr next)) + (cons (make-elevation + (universal-time->global-time-string time) + (string-append + (get-named-content '|lat| result) + ","(get-named-content '|lng| result)) + (get-named-content '|elevation| result) + (get-named-content '|resolution| result)) + elevations))))))))))) + +(define (skip-strings content) + (if (and (pair? content) + (string? (car content))) + (skip-strings (cdr content)) + content)) + +#;(define (reply-elevation.resolution reply) + (let ((root (xml-document-root reply))) + (if (not (eq? '|ElevationResponse| (xml-element-name root))) + (error "Bogus reply:" (xml->string reply))) + (let ((root-content (xml-element-content root))) + (let ((status (get-named-content '|status| root-content))) + (if (not (string=? "OK" status)) + (error "Bad status:" status reply))) + (let ((result-content (xml-element-content + (find-element '|result| root-content)))) + (cons (get-named-content '|elevation| result-content) + (get-named-content '|resolution| result-content)))))) + +(define (remaining-locations locations data) (do ((data data (cdr data)) (locations locations (cdr locations))) ((or (null? locations) (null? data)) (if (null? locations) (error "Nothing to do; data collection is complete.") - (car locations))) + locations)) (let ((logged (elevation/lat-lng (car data))) - (request (car locations))) - (if (not (and (= (latitude logged) (latitude request)) - (= (longitude logged) (longitude request)))) - (error "Log and list mismatched:" logged request))))) + (next (car locations))) + (if (not (and (= (latitude logged) (latitude next)) + (= (longitude logged) (longitude next)))) + (error "Log and list mismatched:" logged next))))) -(define (count-requests-after time data) +(define (count-locations-after time data) (let loop ((count 0) (data data)) (if (pair? data) @@ -100,21 +154,8 @@ USA. (cdr data)) count))) -(define (reply-elevation.resolution reply) - (let ((root (xml-document-root reply))) - (if (not (eq? '|ElevationResponse| (xml-element-name root))) - (error "Bogus reply:" (xml->string reply))) - (let ((root-content (xml-element-content root))) - (let ((status (get-named-content '|status| root-content))) - (if (not (string=? "OK" status)) - (error "Bad status:" status reply))) - (let ((result-content (xml-element-content - (find-element '|result| root-content)))) - (cons (get-named-content '|elevation| result-content) - (get-named-content '|resolution| result-content)))))) - -(define (get-named-content name content) - (get-content (find-element name content))) +(define (get-named-content name element) + (get-content (find-element name (xml-element-content element)))) (define (get-content elt) (let ((con (xml-element-content elt))) @@ -125,14 +166,16 @@ USA. (error "Unexpected content:" elt)))) (define (find-element name content) - (let loop ((content content)) - (if (pair? content) - (let ((elt (car content))) - (if (and (xml-element? elt) - (eq? name (xml-element-name elt))) - elt - (loop (cdr content)))) - (error "Could not find:" name content)))) + (or (let loop ((content content)) + (and (pair? content) + (let ((elt (car content))) + (if (xml-element? elt) + (if (eq? name (xml-element-name elt)) + elt + (or (loop (xml-element-content elt)) + (loop (cdr content)))) + (loop (cdr content)))))) + (error "Could not find:" name content))) (define (read-elevation-data log-file) (if (file-exists? log-file) @@ -153,17 +196,19 @@ USA. (list-ref fields 2) (list-ref fields 3)))) -(define (log-elevation elevation log-file) +(define (log-elevations elevations log-file) (call-with-append-file log-file (lambda (port) - (write-string (vector-ref elevation 0) port) - (write-char #\tab port) - (write-string (vector-ref elevation 1) port) - (write-char #\tab port) - (write-string (vector-ref elevation 2) port) - (write-char #\tab port) - (write-string (vector-ref elevation 3) port) - (newline port)))) + (for-each (lambda (elevation) + (write-string (vector-ref elevation 0) port) + (write-char #\tab port) + (write-string (vector-ref elevation 1) port) + (write-char #\tab port) + (write-string (vector-ref elevation 2) port) + (write-char #\tab port) + (write-string (vector-ref elevation 3) port) + (newline port)) + elevations)))) (define (read-lines port) (let loop () diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg index 33b5269f3..0723c545d 100644 --- a/src/planetarium/mit-3d.pkg +++ b/src/planetarium/mit-3d.pkg @@ -48,9 +48,12 @@ USA. (parent (planetarium)) (files "google-earth-requests") (import () - append-map! burst-string call-with-append-file file-exists? - iota write-string read-line + list-head append-map! + burst-string decorated-string-append + call-with-append-file file-exists? + iota write-string read-line number->string string->number string->universal-time universal-time->global-time-string + load-option open-input-gfile read-xml xml->string xml-document-root xml-element? xml-element-content xml-element-name)