From: Matt Birkholz Date: Mon, 4 Nov 2013 00:46:02 +0000 (-0700) Subject: planetarium: Add request-google-elevation, make-google-elevations. X-Git-Tag: mit-scheme-pucked-9.2.12~431 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=30090926ab87568206dd9e72af456507e3def56e;p=mit-scheme.git planetarium: Add request-google-elevation, make-google-elevations. Make-google-elevations creates a viewing a height map created from the data collected by request-google-elevation. --- diff --git a/src/planetarium/google-earth-requests.scm b/src/planetarium/google-earth-requests.scm new file mode 100644 index 000000000..f9a796b59 --- /dev/null +++ b/src/planetarium/google-earth-requests.scm @@ -0,0 +1,197 @@ +#| -*-Scheme-*- + +Copyright (C) 2013 Matthew Birkholz + +This file is part of an extension to MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Query Google Earth data + +;; The Elevation API has the following limits in place: +;; +;; 2,500 requests per day. +;; 512 locations per request. +;; 25,000 total locations per day. + +;; 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. + +(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. + (if (not (file-exists? "monterey-bay.txt")) + (error "Could not find google-elevation-requests.txt.")) + (request-google-elevation (let ((longs (iota 101 -122.5 0.01)) + (lats (iota 101 36 0.01))) + (append-map! + (lambda (lat) + (map (lambda (long) + (make-latitude/longitude lat long)) + longs)) + lats)) + "monterey-bay.txt")) + +(define (request-google-elevation locations log-file) + (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)) + (error "Request allowance exceeded.")) + ;; Send request. + (log-elevation (send-next-elevation-request locations data time) log-file))) + +(define (send-next-elevation-request locations data time) + (let* ((location (next-elevation-location locations data)) + (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) + (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))) + (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))))) + +(define (count-requests-after time data) + (let loop ((count 0) + (data data)) + (if (pair? data) + (loop (if (< time (elevation/time (car data))) + (1+ count) + count) + (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-content elt) + (let ((con (xml-element-content elt))) + (if (and (pair? con) + (string? (car con)) + (null? (cdr con))) + (car con) + (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)))) + +(define (read-elevation-data log-file) + (if (file-exists? log-file) + (let* ((lines + (call-with-input-file log-file read-lines)) + (l (length lines))) + (map parse-logged-elevation + (list-tail lines + (if (< l 2502) + 0 + (- l 2502))))) + '())) + +(define (parse-logged-elevation line) + (let ((fields (burst-string line #\tab #f))) + (make-elevation (list-ref fields 0) + (list-ref fields 1) + (list-ref fields 2) + (list-ref fields 3)))) + +(define (log-elevation elevation 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)))) + +(define (read-lines port) + (let loop () + (let ((line (read-line port))) + (if (eof-object? line) + '() + (cons line (loop)))))) + +(define (make-elevation time-string + lat/lng-string + elevation-string + resolution-string) + (vector time-string lat/lng-string elevation-string resolution-string)) + +(define (elevation/time elevation) + (string->universal-time (vector-ref elevation 0))) + +(define (elevation/lat-lng elevation) + (let ((lat-lng (burst-string (vector-ref elevation 1) #\, #f))) + (if (= 2 (length lat-lng)) + (make-latitude/longitude (string->number (car lat-lng)) + (string->number (cadr lat-lng))) + (error "Bogus lat/lng:" elevation)))) + +(define (elevation/elevation elevation) + (or (string->number (vector-ref elevation 2)) + (error "Bogus elevation:" elevation))) + +(define (elevation/resolution elevation) + (or (string->number (vector-ref elevation 3)) + (error "Bogus resolution:" elevation))) \ No newline at end of file diff --git a/src/planetarium/google-earth.scm b/src/planetarium/google-earth.scm new file mode 100644 index 000000000..622b8352f --- /dev/null +++ b/src/planetarium/google-earth.scm @@ -0,0 +1,224 @@ +#| -*-Scheme-*- + +Copyright (C) 2013 Matthew Birkholz + +This file is part of an extension to MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Draw Google Elevation data. + +(define (make-google-elevations filename) + (let ((matrix (make-heightmap-matrix filename)) + (start (make-latitude/longitude 122.5 36.0)) + (step 0.05)) + (with-glx-viewport 400 400 "Google Elevations" + (lambda (widget) + (declare (ignore widget)) + (draw-heightmap matrix start step))))) + +(define (draw-heightmap matrix start step) + (%trace2 ";draw-heightmap "start" "step"\n") + ;; MATRIX should contain metric height information per latitude/ + ;; longitude. MATRIX[0,0] would be the height in meters at the + ;; START location, a latitude/longitude. MATRIX[0,1] is the height + ;; at a position STEP degrees due East. MATRIX[1,0] is the height + ;; STEP degrees North. + + (gl:shade-model 'SMOOTH) ; Enable Smooth Shading + (gl:clear-color (color .5 .5 .5 .5)) ; Gray Background + (gl:clear-depth 1.) ; Depth Buffer Setup + (gl:enable 'DEPTH-TEST) ; Enables Depth Testing + (gl:depth-func 'LEQUAL) ; The Type Of Depth Testing To Do + (gl:enable 'CULL-FACE) + (gl:cull-face 'BACK) + ;; Really Nice Perspective Calculations + (gl:hint 'PERSPECTIVE-CORRECTION 'NICEST) + + (let ((columns (matrix-columns matrix)) + (rows (matrix-rows matrix))) + + ;; MATRIX contains heights in meters. To use these floats directly + ;; we scale the matrix indices into meters, multiplying by a + ;; step-factor -- meters along the earth's surface for STEP degrees + ;; of longitude. + (let ((step-factor + (let ((lat (latitude start)) + (lng-start (longitude start))) + (let ((lng-end (+ lng-start (* step columns)))) + (/ (geodesic-distance + (make-latitude/longitude lat lng-start) + (make-latitude/longitude lat lng-end)) + columns))))) + + (define update-color + (let ((min.max (matrix-min.max matrix))) + (%trace2 ";draw-heightmap matrix min.max = "min.max"\n") + (named-lambda (update-color h) + (gl:color + (if (flo:positive? h) + (color 0. (/ h (cdr min.max)) 0. 1.) + (color 0. 0. (/ h (car min.max)) 1.)))))) + + (define (vertex x y) + (let ((h (matrix-ref matrix x y))) + + #;(define (update-normal x y) + (gl:normal + (normal h + (ref (fix:-1+ x) y) ; east + (ref (fix:1+ x) y) ; west + (ref x (fix:1+ y)) ; north + (ref x (fix:-1+ y))))) ; south + + #;(define (ref x y) + (if (or (fix:= x -1) + (fix:= x rows) + (fix:= y -1) + (fix:= y columns)) + #f + (matrix-ref matrix x y))) + + (update-color h) + #;(update-normal matrix x y) + (gl:vertex + (flo:3d (flo:* (->flonum x) step-factor) + h + (flo:* (->flonum y) step-factor))))) + + (%trace2 ";draw-heightmap step-factor="step-factor"\n") + + ;; Translate to center of [0., 2.) cube. + (gl:translate -1. 0. -1.) + + ;; Scale so X is [0., 2.). + (let ((K (/ 2. (* step-factor rows)))) + (%trace2 ";draw-heightmap gl:scale "K"\n") + (gl:scale K K K)) + +#| + (gl:enable 'NORMALIZE) + (gl:color-material 'FRONT 'DIFFUSE) + (gl:enable 'COLOR-MATERIAL) + + glLightfv(GL_LIGHT0,GL_AMBIENT,{0.3,0.3,0.3,1.0}); + glLightfv(GL_LIGHT0,GL_DIFFUSE,{1.0,1.0,1.0,1.0}); + glLightfv(GL_LIGHT0,GL_SPECULAR,{1.0,1.0,1.0,1.0}); + glLightModeli(GL_LIGHT_MODEL_LOCAL_VIEWER,GL_TRUE); + glEnable(GL_LIGHTING); + glEnable(GL_LIGHT0); + + glLightfv(GL_LIGHT0,GL_POSITION,{0.0,100.0,0.0,1.0}); + glMaterialfv(GL_FRONT, GL_SPECULAR, {1.0,1.0,1.0,1.0}); + glMaterialfv(GL_FRONT, GL_SHININESS,{128.0}); + glMaterialfv(GL_FRONT, GL_AMBIENT, {0.1,0.1,0.1,1.0}); + glMaterialfv(GL_FRONT, GL_DIFFUSE, {1.0,1.0,1.0,1.0}); +|# + + (gl:begin 'QUADS) ; or LINES for wireframe + (%trace2 ";draw-heightmap gl:begin\n") + (let ((last-row (fix:- rows 2)) + (last-column (fix:- columns 2))) + (do ((y 0 (fix:1+ y))) + ((fix:= y last-row)) + (do ((x 0 (fix:1+ x))) + ((fix:= x last-column)) + (vertex x y) + (vertex x (fix:1+ y)) + (vertex (fix:1+ x) (fix:1+ y)) + (vertex (fix:1+ x) y)))) + (%trace2 ";draw-heightmap gl:end\n") + (gl:end)))) + +(define (make-heightmap-matrix filename) + (let ((matrix (flo:vector-cons 400))) + (let ((rows (matrix-rows matrix)) + (cols (matrix-columns matrix))) + (call-with-input-file filename + (lambda (in) + (do ((y 0 (fix:1+ y))) + ((fix:= y rows)) + (do ((x 0 (fix:1+ x))) + ((fix:= x cols)) + (let ((line (read-line in))) + (if (eof-object? line) (error "No more data?")) + (let ((fields (burst-string line #\tab #f))) + (let ((height (->flonum (string->number + (list-ref fields 2))))) + (matrix-set! matrix x y height))))))))) + matrix)) + +(define-integrable (matrix-columns m) + (declare (ignore m)) + 20) + +(define-integrable (matrix-rows m) + (declare (ignore m)) + 20) + +(define-integrable (matrix-set! m x y v) + (flo:vector-set! m (fix:+ x (fix:* 20 y)) v)) + +(define-integrable (matrix-ref m x y) + (flo:vector-ref m (fix:+ x (fix:* 20 y)))) + +(define (matrix-min.max m) + (let ((min #f) + (max #f) + (rows (matrix-rows m)) + (cols (matrix-columns m))) + (do ((y 0 (fix:1+ y))) + ((fix:= y rows)) + (do ((x 0 (fix:1+ x))) + ((fix:= x cols)) + (let ((h (matrix-ref m x y))) + (if (or (not min) + (flo:< h min)) + (set! min h)) + (if (or (not max) + (flo:< max h)) + (set! max h))))) + (cons min max))) + +(define-integrable (color r g b a) + (let ((c (flo:vector-cons 4))) + (flo:vector-set! c 0 r) + (flo:vector-set! c 1 g) + (flo:vector-set! c 2 b) + (flo:vector-set! c 3 a) + c)) + +(define-integrable (make-3d-point x y z) + (let ((p (flo:vector-cons 3))) + (flo:vector-set! p 0 x) + (flo:vector-set! p 1 y) + (flo:vector-set! p 2 z) + p)) + +(define-integrable (flo:max a b) + (if (flo:< a b) b a)) + +(define %trace? #t) + +(define (%trace . msg) + (if %trace? (for-each display msg))) + +(define %trace2? #f) + +(define (%trace2 . msg) + (if %trace2? (for-each display msg))) \ No newline at end of file diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg new file mode 100644 index 000000000..33b5269f3 --- /dev/null +++ b/src/planetarium/mit-3d.pkg @@ -0,0 +1,58 @@ +#| -*-Scheme-*- + +Copyright (C) 2013 Matthew Birkholz + +This file is part of an extension to MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; 3D Planetarium Packaging + +(global-definitions runtime/) +(global-definitions xml/) +(global-definitions gtk/) +(global-definitions gl/) +(global-definitions "./mit") + +(define-package (planetarium google-earth) + (parent (planetarium)) + (files "google-earth") + (import () + burst-string read-line string->number) + (import (gl) + with-glx-viewport + gl:begin gl:end gl:clear gl:clear-color gl:clear-depth + gl:color gl:color-material gl:cull-face + gl:depth-func gl:enable gl:disable gl:hint gl:load-identity + gl:scale gl:translate gl:shade-model gl:vertex gl:normal gl:flush + glu:look-at) + (export () + make-google-elevations)) + +(define-package (planetarium google-earth requests) + (parent (planetarium)) + (files "google-earth-requests") + (import () + append-map! burst-string call-with-append-file file-exists? + iota write-string read-line + string->universal-time universal-time->global-time-string + + open-input-gfile read-xml xml->string + xml-document-root xml-element? xml-element-content xml-element-name) + (export (planetarium) + request-google-elevation)) \ No newline at end of file diff --git a/src/planetarium/mit-check.scm b/src/planetarium/mit-check.scm new file mode 100644 index 000000000..7330cc66b --- /dev/null +++ b/src/planetarium/mit-check.scm @@ -0,0 +1,13 @@ +#| -*-Scheme-*- |# + +;;;; Test the Planetarium. + +(load "mit-make") +(make-tellurion) +(make-google-elevations "monterey-bay.txt") +(let ((gtk (->environment '(gtk gtk-widget)))) + (let wait () + (if (not (null? (access toplevel-windows gtk))) + (begin + (sleep-current-thread 1000) + (wait))))) \ No newline at end of file diff --git a/src/planetarium/mit-compile-3d.scm b/src/planetarium/mit-compile-3d.scm new file mode 100644 index 000000000..15d178d7c --- /dev/null +++ b/src/planetarium/mit-compile-3d.scm @@ -0,0 +1,47 @@ +#| -*-Scheme-*- + +Copyright (C) 2013 Matthew Birkholz + +This file is part of an extension to MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Compile a 3D Planetarium. + +(load-option 'GL) + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (fluid-let ((compile-file:sf-only? #f)) + (load "mit-compile") + (load-package-set "mit") + + (let ((package-set (package-set-pathname "mit-3d"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "mit-3d")) + (construct-packages-from-file (fasload package-set))) + + (let ((env (->environment '(planetarium google-earth)))) + (compile-file "google-earth" '() env) + (load "google-earth" env)) + + (let ((env (->environment '(planetarium google-earth requests)))) + (compile-file "google-earth-requests" '() env) + (load "google-earth-requests" env)) + + (cref/generate-constructors "mit-3d" 'ALL)))) \ No newline at end of file diff --git a/src/planetarium/mit-make.scm b/src/planetarium/mit-make.scm index d7cf58f10..e05f1a772 100644 --- a/src/planetarium/mit-make.scm +++ b/src/planetarium/mit-make.scm @@ -1,11 +1,39 @@ #| -*-Scheme-*- -Load the Planetarium. |# +Copyright (C) 2013 Matthew Birkholz + +This file is part of an extension to MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Load the PLANETARIUM option. + +;;; Check for a GL option and load the 3D parts of the Planetarium +;;; when it is available. (This presumes the 3D portion was +;;; installed.) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (load-package-set "mit"))) + (load-package-set "mit") + ((access test-angular-separation (->environment '(planetarium)))) + (if (not (warn-errors? (lambda () (load-option 'GL)))) + (load-package-set "mit-3d")))) (let ((planet (->environment '(planetarium))) (graphics (cond ((graphics-type-available? 'gtk)