--- /dev/null
+#| -*-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))))
+\f
+(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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
#| -*-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)
projects / mit-scheme.git / commitdiff