;; 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)
(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: <result> with <elevation> and <resolution>.
+ (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)
(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)))
(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)
(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))))
\f
(define (read-lines port)
(let loop ()
projects / mit-scheme.git / commitdiff