From a16257e0211d0dbf9a9699f93ad39fd4bffc1407 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 11 Nov 2013 15:31:15 -0700 Subject: [PATCH] Use the new, flying and draw a shaded terrainmap. Add a label to the terrain window showing position, altitude and heading. Also convert request-google-elevation to request-google-elevationS, which loops making a request every 60 seconds, and add a jasper-seamount procedure. --- src/planetarium/geometry.scm | 61 ++- src/planetarium/google-earth-requests.scm | 239 ----------- src/planetarium/google-earth.scm | 409 +++++++++--------- src/planetarium/mit-3d.pkg | 59 ++- src/planetarium/mit-check.scm | 27 +- src/planetarium/mit-compile-3d.scm | 31 +- src/planetarium/mit-compile.scm | 46 +-- src/planetarium/mit-link.scm | 41 ++ src/planetarium/mit-make.scm | 21 +- src/planetarium/mit-r3rs.scm | 20 +- src/planetarium/terrain.scm | 483 ++++++++++++++++++++++ 11 files changed, 905 insertions(+), 532 deletions(-) delete mode 100644 src/planetarium/google-earth-requests.scm create mode 100644 src/planetarium/mit-link.scm create mode 100644 src/planetarium/terrain.scm diff --git a/src/planetarium/geometry.scm b/src/planetarium/geometry.scm index 9026b05c7..9a99f86fb 100644 --- a/src/planetarium/geometry.scm +++ b/src/planetarium/geometry.scm @@ -21,9 +21,10 @@ USA. |# -(define-integrable pi (flo:* 4. (flo:atan2 1. 1.))) -(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.))) -(define-integrable pi/2 (flo:* 2. (flo:atan2 1. 1.))) +(define-integrable pi/4 (flo:atan2 1. 1.)) +(define-integrable pi (flo:* 4. pi/4)) +(define-integrable 2pi (flo:* 8. pi/4)) +(define-integrable pi/2 (flo:* 2. pi/4)) (define-integrable -pi/2 (flo:negate pi/2)) (define-integrable (flo:2d x y) @@ -45,6 +46,16 @@ USA. (define-integrable (flo.3 v) (flo:vector-ref v 2)) (define-integrable (flo.3! v f) (flo:vector-set! v 2 f)) +(define-integrable (flo:4d r g b a) + (let ((v (flo:vector-cons 4))) + (flo:vector-set! v 0 r) + (flo:vector-set! v 1 g) + (flo:vector-set! v 2 b) + (flo:vector-set! v 3 a) + v)) +(define-integrable (flo.4 v) (flo:vector-ref v 3)) +(define-integrable (flo.4! v f) (flo:vector-set! v 3 f)) + (define-integrable (make-2d-point x y) (flo:2d x y)) (define-integrable (x p) (flo.1 p)) (define-integrable (set-x! p x) (flo.1! p x)) @@ -107,6 +118,33 @@ USA. (flo:+ r+frac 360.) r+frac))))) +(define (latitude-longitude->string lat/lng) + ;; Format a latitude/longitude in the standard form, e.g. + ;; + ;; 30°26.40′N 122°44.40′W + + (let ((lat (latitude lat/lng)) + (lng (longitude lat/lng))) + (let ((neg-lat? (flo:negative? lat)) + (neg-lng? (flo:negative? lng)) + (abs-lat (flo:abs lat)) + (abs-lng (flo:abs lng))) + (let ((lat-deg (flo:truncate abs-lat)) + (lng-deg (flo:truncate abs-lng))) + (let ((lat-min (flo:* (flo:- abs-lat lat-deg) 60.)) + (lng-min (flo:* (flo:- abs-lng lng-deg) 60.))) + (string-append + (number->string (inexact->exact lat-deg) '(int)) + "°" + (number->string lat-min '(fix 2)) + "′" + (if neg-lat? "S " "N ") + (number->string (inexact->exact lng-deg) '(int)) + "°" + (number->string lng-min '(fix 2)) + "′" + (if neg-lng? "W" "E"))))))) + (define (geodesic-distance p1 p2) ;; "[Given] the geographic coordinates of two points on the surface ;; of the Earth [...] the shortest distance S between these points, @@ -125,10 +163,7 @@ USA. ;; communicated the following method. [...] Mathematically ;; speaking, this method is completely identical to formula 17.1, ;; but a computer will yield more accurate results from an - ;; arctangent than from an arccosine." [p.115] - ;; -Meeus 2009, specifically the second English edition (1998) "with - ;; corrections as of August 10, 2009" of _Astronomical_Algorithms_ - ;; by Jean Meeus. + ;; arctangent than from an arccosine." [p.115] -Meeus 2009 (let ((lat1 (degrees->radians (latitude p1))) (lng1 (degrees->radians (longitude p1))) @@ -195,5 +230,13 @@ USA. (define (flo:~= n1 n2 epsilon) ;; aka approximately-= - (and (flo:flonum? n1) (flo:flonum? n2) (flo:flonum? epsilon) - (flo:< (flo:abs (flo:- n2 n1)) epsilon))) \ No newline at end of file + (flo:< (flo:abs (flo:- n2 n1)) epsilon)) + +(define (2d-~= p1 p2 epsilon) + (and (flo:~= (x p1) (x p2) epsilon) + (flo:~= (y p1) (y p2) epsilon))) + +(define (3d-~= p1 p2 epsilon) + (and (flo:~= (x p1) (x p2) epsilon) + (flo:~= (y p1) (y p2) epsilon)) + (flo:~= (z p1) (z p2) epsilon)) \ No newline at end of file diff --git a/src/planetarium/google-earth-requests.scm b/src/planetarium/google-earth-requests.scm deleted file mode 100644 index ce1fc4a0e..000000000 --- a/src/planetarium/google-earth-requests.scm +++ /dev/null @@ -1,239 +0,0 @@ -#| -*-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. -;; -;; 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. 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 monterey-bay.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 (< 20000 (count-locations-after (- time (* 24 60 60)) data)) - (error "Request allowance exceeded.")) - ;; Send request. - (log-elevations (send-next-elevation-request locations data time) - log-file))) - -(define (send-next-elevation-request locations data time) - (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=" - (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") - (open-input-string (http-response-body (http-get url '())))) - (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.") - locations)) - (let ((logged (elevation/lat-lng (car data))) - (next (car locations))) - (if (not (and (= (latitude logged) (latitude next)) - (= (longitude logged) (longitude next)))) - (error "Log and list mismatched:" logged next))))) - -(define (count-locations-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 (get-named-content name element) - (get-content (find-element name (xml-element-content element)))) - -(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) - (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) - (let* ((lines - (call-with-input-file log-file read-lines)) - (l (length lines))) - (map parse-logged-elevation lines)) - '())) - -(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-elevations elevations log-file) - (call-with-append-file log-file - (lambda (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 () - (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 index 622b8352f..dc3eb853c 100644 --- a/src/planetarium/google-earth.scm +++ b/src/planetarium/google-earth.scm @@ -21,204 +21,211 @@ 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 +;;;; 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. +;; +;; URLs are restricted to 2048 characters. + +(define (monterey-bay) + ;; This procedure requests the elevations at locations on a 101x101 + ;; gid between 36,-122.5 and 37,-121.5 inclusive -- the coast and + ;; sea floor of Monterey Bay. At 11520 elevations per day, the + ;; 10201 elevations can be fetched in 0.89 days. + (request-google-elevations "monterey-bay-101x101.txt" + (make-latitudes/longitudes + (iota 101 36. .01) + (iota 101 -122.5 .01)))) + +(define (jasper-seamount) + ;; This procedure requests the elevations at locations on a 101x101 + ;; grid between 30.07,-122.67 and 30.57,-122.17 -- centered on the + ;; Jasper Seamount (30°26.40′N 122°44.40′W). At 11520 elevations + ;; per day, the 10201 elevations can be fetched in 0.89 days. + (request-google-elevations "jasper-seamount-101x101.txt" + (make-latitudes/longitudes + (iota 101 30.07 .005) + (iota 101 -122.67 .005)))) + +(define (make-latitudes/longitudes lats lngs) + (append-map! (lambda (lat) + (map (lambda (lng) + (make-latitude/longitude lat lng)) + lngs)) + lats)) + +(define (request-google-elevations log-file locations) + ;; This procedure requests 8 elevations once a minute -- 1440 + ;; requests and 11520 elevations per day. It logs its progress to + ;; LOG-FILE and is restartable, picking up where the log stops. In + ;; fact it won't start if there is no log. + (if (not (file-exists? log-file)) + (error "Could not find log file:" log-file)) + + (load-option 'xml) + + (let loop ((locations (remaining-locations locations + (read-elevation-data log-file)))) + (if (not (null? locations)) + (let* ((last (if (< 7 (length locations)) + (list-tail locations 7) + '())) + (rest (if (pair? last) + (let ((rest (cdr last))) + (set-cdr! last '()) + rest) + '()))) + (log-elevations (request-elevations locations) log-file) + (sleep-current-thread 60000) + (loop rest))))) + +(define (request-elevations locations) + (if (not (< locations 9)) + (error "Too many locations for request:" locations)) + (let ((time (get-universal-time)) + (url (string-append + "http://maps.googleapis.com/maps/api/elevation/" + "xml?sensor=false&locations=" + (decorated-string-append + "" "%7C" "" + (map (lambda (location) + (string-append + (number->string (latitude location)) + ","(number->string (longitude location)))) + locations))))) + (let* ((port #;(open-input-file "reply.txt") + #;(open-input-gfile url) + (open-input-string (http-response-body (http-get url '())))) + (reply (read-xml 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 (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.") + locations)) + (let ((logged (elevation/lat-lng (car data))) + (next (car locations))) + (if (not (and (= (latitude logged) (latitude next)) + (= (longitude logged) (longitude next)))) + (error "Log and list mismatched:" logged next))))) + +(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))) + (if (and (pair? con) + (string? (car con)) + (null? (cdr con))) + (car con) + (error "Unexpected content:" elt)))) + +(define (find-element 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) + (map parse-logged-elevation + (call-with-input-file log-file read-lines)) + '())) + +(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-elevations elevations log-file) + (call-with-append-file log-file + (lambda (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 () + (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/mit-3d.pkg b/src/planetarium/mit-3d.pkg index 67b93d90c..ab0d04f80 100644 --- a/src/planetarium/mit-3d.pkg +++ b/src/planetarium/mit-3d.pkg @@ -24,40 +24,71 @@ USA. ;;;; 3D Planetarium Packaging (global-definitions runtime/) +(global-definitions sos/) (global-definitions xml/) (global-definitions gtk/) (global-definitions gl/) (global-definitions "./mit") -(define-package (planetarium google-earth) +(define-package (planetarium terrain) (parent (planetarium)) - (files "google-earth") + (files "terrain") (import () - burst-string read-line string->number) + burst-string read-line ->namestring + error:wrong-type-argument flo:= flo:>= flo:flonum? symbol-name + guarantee-list-of-type->length guarantee-symbol guarantee-string + sleep-current-thread + define-class define-method initialize-instance) + (import (gtk) + gtk-widget-set-hexpand + gtk-widget-set-vexpand + gtk-widget-queue-draw + gtk-label-new gtk-label-set-text + gtk-container-add + gtk-container-set-border-width + gtk-grid-new gtk-grid-attach + gtk-widget-show-all + gtk-window-new + gtk-window-set-title + fix-widget-realize-callback) (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) + with-glx-widget + + glx-viewport-draw + glx-viewport-key-press-handler + glx-viewport-position + glx-viewport-heading + glx-viewport-tilt + + gl:begin gl:call-list gl:clear gl:clear-color gl:clear-depth + gl:color gl:color-material gl:cull-face gl:depth-func + gl:blend-func gl:disable gl:enable gl:end gl:end-list + gl:flush gl:gen-lists gl:hint gl:light gl:light-model + gl:load-identity gl:material gl:new-list gl:normal gl:scale + gl:shade-model gl:translate gl:vertex glu:look-at) + (import (gl internals glx) + set-glx-viewport-heading! + set-glx-viewport-tilt! + set-glx-viewport-step-size! + set-glx-viewport-near! + set-glx-viewport-far!) (export () - make-google-elevations)) + make-terrain)) -(define-package (planetarium google-earth requests) +(define-package (planetarium google-earth) (parent (planetarium)) - (files "google-earth-requests") + (files "google-earth") (import () 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 + load-option sleep-current-thread open-input-gfile http-get http-response-body open-input-string 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 + request-google-elevations)) \ No newline at end of file diff --git a/src/planetarium/mit-check.scm b/src/planetarium/mit-check.scm index 7330cc66b..621e4b700 100644 --- a/src/planetarium/mit-check.scm +++ b/src/planetarium/mit-check.scm @@ -3,11 +3,22 @@ ;;;; 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 + +;;(make-fix-layout-demo) + +;;(make-tellurion) + +(if (name->package '(planetarium terrain)) + (if (file-readable? "monterey-bay-101x101.txt") + (let ((view (make-terrain "monterey-bay-101x101.txt" + 101 101 36. -122.5 .01))) + (view 'position 36.5 -122.7 15000.) + (view 'heading 85.) + (view 'tilt -25.)) + (warn "Could not test terrain viewer."))) + +(let wait () + (if (not (null? (access toplevel-windows (->environment '(gtk gtk-widget))))) + (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 index 15d178d7c..b3af74808 100644 --- a/src/planetarium/mit-compile-3d.scm +++ b/src/planetarium/mit-compile-3d.scm @@ -23,25 +23,28 @@ USA. ;;;; Compile a 3D Planetarium. +(load-option 'CREF) +(load-option 'SOS) +(load-option 'GTK) (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") + (define (load-compiled file deps pkg-name) + (let ((env (->environment pkg-name))) + (compile-file file deps env) + (load file env))) - (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))) + (load "mit-compile") - (let ((env (->environment '(planetarium google-earth)))) - (compile-file "google-earth" '() env) - (load "google-earth" env)) + (let ((package-set (package-set-pathname "mit-3d"))) + (if (not (file-modification-timeenvironment '(planetarium google-earth requests)))) - (compile-file "google-earth-requests" '() env) - (load "google-earth-requests" env)) + (fluid-let ((compile-file:sf-only? #f)) + (load-compiled "terrain" '("geometry") '(planetarium terrain)) + ((access test-normals (->environment '(planetarium terrain)))) + (load-compiled "google-earth" '() '(planetarium google-earth))) - (cref/generate-constructors "mit-3d" 'ALL)))) \ No newline at end of file + (cref/generate-constructors "mit-3d"))) \ No newline at end of file diff --git a/src/planetarium/mit-compile.scm b/src/planetarium/mit-compile.scm index 453d92ad0..5ec5ae039 100644 --- a/src/planetarium/mit-compile.scm +++ b/src/planetarium/mit-compile.scm @@ -22,37 +22,33 @@ USA. |# (load-option 'CREF) +(load-option 'GTK) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () + (define (load-compiled file deps pkg-name) + (let ((env (->environment pkg-name))) + (compile-file file deps env) + (load file env))) + (if (name->package '(PLANETARIUM)) (error "The PLANETARIUM package already exists.") (let ((package-set (package-set-pathname "mit"))) - (if (not (file-exists? package-set)) + (if (not (file-modification-timeenvironment '(r3rs extras))) - (load "mit-r3rs" (->environment '(r3rs extras))) - - (compile-file "mit-syntax" '() (->environment '(planetarium syntax))) - (load "mit-syntax" (->environment '(planetarium syntax))) - - (let ((planet (->environment '(planetarium)))) - (for-each (lambda (file) (compile-file file '() planet)) - '("geometry" "matrices" "time" "graphics")) - (compile-file "solar" '("geometry") planet) - (compile-file "earth" '("geometry" "matrices") planet) - (compile-file "tellurion" '("geometry" "matrices") planet)) - - (compile-file "mit-gtk" '() - (->environment '(planetarium gtk-graphics))) - (compile-file "mit-x" '() - (->environment '(planetarium x-graphics))) - (compile-file "mit-graphics" '() - (->environment '(planetarium simple-graphics))) - - (compile-file "mit-cil" `("mit-syntax" ,@(directory-read "cil-*.txt")) - (->environment '(planetarium earth-cil))) - - (cref/generate-constructors "mit" 'ALL))) \ No newline at end of file + (load-compiled "mit-r3rs" '() '(r3rs extras)) + (load-compiled "mit-syntax" '() '(planetarium syntax)) + (for-each (lambda (file) (load-compiled file '() '(planetarium))) + '("geometry" "matrices" "time" "graphics" "solar" "geometry")) + ((access test-angular-separation (->environment '(planetarium)))) + (load-compiled "earth" '("geometry" "matrices") '(planetarium)) + (load-compiled "tellurion" '("geometry" "matrices") '(planetarium)) + (load-compiled "mit-gtk" '() '(planetarium gtk-graphics)) + (load-compiled "mit-x" '() '(planetarium x-graphics)) + (load-compiled "mit-graphics" '() '(planetarium simple-graphics)) + (load-compiled "mit-cil" + `("mit-syntax" ,@(directory-read "cil-*.txt")) + '(planetarium earth-cil)) + (cref/generate-constructors "mit"))) \ No newline at end of file diff --git a/src/planetarium/mit-link.scm b/src/planetarium/mit-link.scm new file mode 100644 index 000000000..0ba03127b --- /dev/null +++ b/src/planetarium/mit-link.scm @@ -0,0 +1,41 @@ +#| -*-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. + +|# + +;;;; Link a graphics type into the (planetarium) package. + +(warn-errors? (lambda () (load-option 'GTK))) +(let ((planet (->environment '(planetarium))) + (graphics (cond ((graphics-type-available? 'gtk) + (->environment '(planetarium gtk-graphics))) + ((graphics-type-available? 'x) + (->environment '(planetarium x-graphics))) + ((not (null? (enumerate-graphics-types))) + (->environment '(planetarium simple-graphics))) + (else #f)))) + (if graphics + (for-each (lambda (name) (environment-link-name planet graphics name)) + '(make-suitable-graphics-device + draw-segment draw-circle draw-text + fill-polygon-available? fill-polygon + clear-graphics flush-graphics)) + (error "No graphics available."))) \ No newline at end of file diff --git a/src/planetarium/mit-make.scm b/src/planetarium/mit-make.scm index e05f1a772..ede67a0c2 100644 --- a/src/planetarium/mit-make.scm +++ b/src/planetarium/mit-make.scm @@ -31,22 +31,7 @@ USA. (directory-pathname (current-load-pathname)) (lambda () (load-package-set "mit") - ((access test-angular-separation (->environment '(planetarium)))) + (load "mit-link") (if (not (warn-errors? (lambda () (load-option 'GL)))) - (load-package-set "mit-3d")))) - -(let ((planet (->environment '(planetarium))) - (graphics (cond ((graphics-type-available? 'gtk) - (->environment '(planetarium gtk-graphics))) - ((graphics-type-available? 'x) - (->environment '(planetarium x-graphics))) - ((not (null? (enumerate-graphics-types))) - (->environment '(planetarium simple-graphics))) - (else #f)))) - (if graphics - (for-each (lambda (name) (environment-link-name planet graphics name)) - '(make-suitable-graphics-device - draw-segment draw-circle draw-text - fill-polygon-available? fill-polygon - clear-graphics flush-graphics)) - (error "No graphics available."))) \ No newline at end of file + (begin + (load-package-set "mit-3d"))))) \ No newline at end of file diff --git a/src/planetarium/mit-r3rs.scm b/src/planetarium/mit-r3rs.scm index 6d70a0152..a2b563ec7 100644 --- a/src/planetarium/mit-r3rs.scm +++ b/src/planetarium/mit-r3rs.scm @@ -62,10 +62,22 @@ USA. (string-append a b)) (define (r3rs-number->string number format) - (if (not (and (equal? format '(int)) - (integer? number))) - (warn "Unimplemented: r3rs-number->string:" number format)) - (number->string number)) + (cond ((and (equal? format '(INT)) + (integer? number)) + (number->string number)) + ((and (eq? (car format) 'FIX) + (integer? (cadr format)) + (null? (cddr format))) + (let* ((whole (truncate->exact number)) + (fract (round->exact + (* (expt 10 (cadr format)) (abs (- number whole)))))) + (string-append (number->string whole) + "." + (string-pad-left (number->string fract) + (cadr format) #\0)))) + (else + (warn "Unimplemented: r3rs-number->string:" number format) + (number->string number)))) (define (r3rs-string->number string exactness radix) (let ((n (string->number string (case radix diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm new file mode 100644 index 000000000..6c50f6193 --- /dev/null +++ b/src/planetarium/terrain.scm @@ -0,0 +1,483 @@ +#| -*-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 Elevation data. + +(declare (integrate-external "geometry")) + +(define (make-terrain filename rows columns lat lng step) + (let ((widget (%make-terrain filename rows columns lat lng step))) + (named-lambda (terrain command . args) + + (define (check-flonum-args num description) + (if (not (= num (guarantee-list-of-type->length + args flo:flonum? "a flonum" 'TERRAIN))) + (error (string-append + "The "(symbol-name command)" command requires" + (number->string num '(int))" arguments: "description".")))) + + (guarantee-symbol command 'TERRAIN) + (cond + ((eq? 'POSITION command) + (check-flonum-args 3 "LATITUDE, LONGITUDE and ALTITUDE") + (let ((lat (car args)) + (lng (cadr args)) + (alt (caddr args))) + (if (not (flo:<= (flo:abs lat) 80.)) + (error "Requested latitude is greater than 80°:" lat)) + (let ((pos (glx-viewport-position widget)) + (origin (terrain-viewport-origin widget)) + (m/d (flo:/ (terrain-viewport-step-meters widget) + (terrain-viewport-step-degrees widget)))) + (set-x! pos (flo:* m/d (flo:- lng (longitude origin)))) + (set-y! pos alt) + (set-z! pos (flo:* m/d (flo:- (latitude origin) lat))))) + (gtk-widget-queue-draw widget)) + + ((eq? 'HEADING command) + (check-flonum-args 1 "AZIMUTH") + (set-glx-viewport-heading! widget (degrees->radians (car args))) + (gtk-widget-queue-draw widget)) + + ((eq? 'TILT command) + (check-flonum-args 1 "INCLINATION in degrees") + (if (not (flo:<= (flo:abs (car args)) 80.)) + (error "Requested inclination greater than 80°.") + (set-glx-viewport-tilt! widget (degrees->radians (car args)))) + (gtk-widget-queue-draw widget)) + + (else + (error:wrong-type-argument command "a command name" 'TERRAIN)))))) + +(define (%make-terrain filename rows columns lat lng step) + (let ((window (gtk-window-new 'toplevel)) + (grid (gtk-grid-new)) + (label (gtk-label-new "")) + (matrix (make-heightmap-matrix filename rows columns))) + (gtk-window-set-title window (string-append "Terrain: " + (->namestring filename))) + (gtk-container-set-border-width window 5) + (gtk-widget-set-hexpand label #t) + (let* ((min.max (matrix-min.max matrix rows columns)) + (widget (make-terrain-viewport + matrix rows columns (car min.max) (cdr min.max) + (make-latitude/longitude lat lng) step label + 300 300))) + (gtk-widget-set-vexpand widget #t) + (gtk-widget-set-hexpand widget #t) + (gtk-grid-attach grid widget 0 0 1 1) + (gtk-grid-attach grid label 0 1 1 1) + (gtk-container-add window grid) + (gtk-widget-show-all window) + widget))) + +(define-class ( + (constructor make-terrain-viewport + (matrix rows columns min-height max-height + origin step-degrees label) + (width height))) + () + + ;; MATRIX should contain metric height information per latitude/ + ;; longitude. MATRIX[0,0] would be the height in meters at ORIGIN, + ;; 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. + (matrix define accessor) + (rows define accessor) + (columns define accessor) + (min-height define accessor) + (max-height define accessor) + + (origin define accessor) + (step-degrees define accessor) + + ;; A GtkLabel to update with the current lat/lng, heading, and inclination. + (label define accessor) + + ;; We scale the matrix indices by step-meters -- meters along the + ;; earth's surface for step-degrees of longitude (at the origin's + ;; latitude). No fancy project is used. It is assumed the + ;; latitudes are small and/or do not vary greatly. + (step-meters define standard) + + ;; Update LIGHT0 if changing this: + (light-position define accessor + initializer (lambda () (flo:4d 0. 0. 0. 1.))) + + ;; The display-list for the terrain mesh. + (mesh define standard initial-value #f)) + +(define-method initialize-instance ((widget ) width height) + (%trace "; (initialize-instance )\n") + (call-next-method widget width height) + (let ((origin (terrain-viewport-origin widget)) + (step-degrees (terrain-viewport-step-degrees widget)) + (columns (->flonum (terrain-viewport-columns widget)))) + (let ((lat (latitude origin)) + (lng-orig (longitude origin))) + (let ((lng-end (flo:+ lng-orig (flo:* step-degrees columns)))) + (let ((step-meters + (flo:/ (geodesic-distance + (make-latitude/longitude lat lng-orig) + (make-latitude/longitude lat lng-end)) + columns))) + (set-terrain-viewport-step-meters! widget step-meters) + (set-glx-viewport-step-size! widget 100.) + (set-glx-viewport-near! widget 10.) + (set-glx-viewport-far! widget 150000.) + (let ((light-pos (terrain-viewport-light-position widget))) + (set-x! light-pos (flo:* step-meters (flo:/ columns 2.0))) + (set-y! light-pos 1000.) + (set-z! light-pos 0.))))))) + +(define-method fix-widget-realize-callback ((widget )) + (%trace "; (fix-widget-realize-callback )\n") + (call-next-method widget) + (with-glx-widget widget + (lambda () + (gl:shade-model 'SMOOTH) ; Enable Smooth Shading + ;;(gl:shade-model 'FLAT) + (gl:clear-color (color .527 .805 .977 1.)) ; light sky blue: #x87cefa + (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) + + (gl:light 'LIGHT0 'AMBIENT (color .4 .4 .4 1.)) + (gl:light 'LIGHT0 'DIFFUSE (color 1. 1. 1. 1.)) + (gl:light 'LIGHT0 'SPECULAR (color 1. 1. 1. 1.)) + (gl:light 'LIGHT0 'POSITION (terrain-viewport-light-position widget)) + (gl:light-model 'LOCAL-VIEWER 1.) + (gl:enable 'LIGHTING) + (gl:enable 'LIGHT0) + + (let ((mesh (gl:gen-lists 1))) + (gl:new-list mesh 'COMPILE) + ;;(draw-colored widget) + (draw-shaded widget) + (gl:end-list) + (set-terrain-viewport-mesh! widget mesh)))) + #t) + +(define-method glx-viewport-draw ((widget )) + (with-glx-widget widget + (lambda () + (gl:call-list (terrain-viewport-mesh widget)))) + (update-label widget)) + +(define (update-label widget) + (let ((origin (terrain-viewport-origin widget)) + (pos (glx-viewport-position widget)) + (d/m (flo:/ (terrain-viewport-step-degrees widget) + (terrain-viewport-step-meters widget)))) + + (define (%_5d i) + (let ((s (number->string i '(int)))) + (if (< (string-length s) 5) + (string-pad-left s 5 #\space) + s))) + + (define (meters->degrees m) (flo:* m d/m)) + + (gtk-label-set-text + (terrain-viewport-label widget) + (string-append + (latitude-longitude->string + (make-latitude/longitude + (flo:- (latitude origin) (meters->degrees (z pos))) + (flo:+ (longitude origin) (meters->degrees (x pos))))) + " alt: "(%_5d (flo:round->exact (y pos))) + "m head: "(number->string + (flo:round->exact + (radians->degrees (glx-viewport-heading widget))) '(int)) + "° incl: "(number->string + (flo:round->exact + (radians->degrees (glx-viewport-tilt widget))) '(int)) + "°")))) + +(define (draw-colored widget) + (%trace "; draw-colored "widget"\n") + (let ((step (terrain-viewport-step-meters widget)) + (matrix (terrain-viewport-matrix widget)) + (rows (terrain-viewport-rows widget)) + (columns (terrain-viewport-columns widget))) + (let ((-step (flo:- 0. step))) + + (define (vertex x y) + (let ((h (matrix-ref matrix columns x y))) + (gl:color (height-color widget h)) + (gl:vertex (flo:3d (flo:* (->flonum x) step) + h + (flo:* (->flonum y) -step))))) + + (gl:color-material 'FRONT 'DIFFUSE) + (gl:enable 'COLOR-MATERIAL) + (gl:begin 'QUADS) + (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)) +;;; (gl:begin 'LINE-LOOP) + (vertex x y) + (vertex (fix:1+ x) y) + (vertex (fix:1+ x) (fix:1+ y)) + (vertex x (fix:1+ y)) +;;; (gl:end) + ))) + (gl:end) + (gl:disable 'COLOR-MATERIAL) + (draw-sea-level widget)))) + +(define (draw-sea-level widget) + ;; A translucent blue plane at sea level. + (declare (ignore widget)) + unspecific + #;(let ((rows (terrain-viewport-rows widget)) + (columns (terrain-viewport-columns widget)) + (step (terrain-viewport-step-meters widget))) + (%trace "; disabling LIGHTING\n") + (gl:disable 'LIGHTING) + (%trace "; enabling BLEND\n") + (gl:enable 'BLEND) + (%trace "; setting BLEND-FUNC\n") + (gl:blend-func 'SRC-ALPHA 'ONE-MINUS-SRC-ALPHA) + (%trace "; setting COLOR\n") + (gl:color (flo:4d 0. 0. 1. .1)) + (%trace "; setting NORMAL\n") + (gl:normal (flo:3d 0. 1. 0.)) + (%trace "; beginning QUADS\n") + (gl:begin 'QUADS) + (let ((max-x (flo:* (flo:- (->flonum columns) 1.) step)) + (min-z (flo:* (flo:- 1. (->flonum rows)) step))) + (gl:vertex (flo:3d 0. 0. 0.)) + (gl:vertex (flo:3d max-x 0. 0.)) + (gl:vertex (flo:3d max-x 0. min-z)) + (gl:vertex (flo:3d 0. 0. min-z))) + (%trace "; ending QUADS\n") + (gl:end) + (%trace "; disabling BLEND\n") + (gl:disable 'BLEND) + (%trace "; enabling LIGHTING\n") + (gl:enable 'LIGHTING))) + +(define (draw-shaded widget) + (%trace "; draw-shaded "widget"\n") + (let ((matrix (terrain-viewport-matrix widget)) + (rows (terrain-viewport-rows widget)) + (columns (terrain-viewport-columns widget)) + (step (terrain-viewport-step-meters widget)) + (-step (flo:- 0. (terrain-viewport-step-meters widget)))) + + (define (vertex x y) + (let ((h (matrix-ref matrix columns x y))) + + (define (ref x y) + (if (or (fix:= x -1) + (fix:= x rows) + (fix:= y -1) + (fix:= y columns)) + #f + (matrix-ref matrix columns x y))) + + (gl:normal (normal step 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 + (gl:color (height-color widget h)) + (gl:vertex (flo:3d (flo:* (->flonum x) step) + h + (flo:* (->flonum y) -step))))) + + (gl:material 'FRONT-AND-BACK 'SPECULAR (flo:4d 1. 1. 1. 1.)) + (gl:material 'FRONT 'SHININESS 128.0) + (gl:material 'FRONT-AND-BACK 'AMBIENT (flo:4d .1 .1 .1 1.)) + (gl:material 'FRONT-AND-BACK 'DIFFUSE (flo:4d 1. 1. 1. 1.)) + (gl:color-material 'FRONT-AND-BACK 'AMBIENT-AND-DIFFUSE) + (gl:enable 'COLOR-MATERIAL) + (gl:begin 'QUADS) ; or LINES for wireframe + (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 (fix:1+ x) y) + (vertex (fix:1+ x) (fix:1+ y)) + (vertex x (fix:1+ y))))) + (gl:end) + (gl:disable 'COLOR-MATERIAL) + (draw-sea-level widget))) + +(define (normal step height east west north south) + (let ((-step (flo:- 0. step))) + + ;; Pretend edges go flat. + (if (not east) (set! east height)) + (if (not west) (set! west height)) + (if (not north) (set! north height)) + (if (not south) (set! south height)) + + (let ((n (3d-sum + (normalized-3d-cross-product + (flo:3d step east 0.) + (flo:3d 0. north -step)) + (3d-sum + (normalized-3d-cross-product + (flo:3d 0. north -step) + (flo:3d -step west 0.)) + (3d-sum + (normalized-3d-cross-product + (flo:3d -step west 0.) + (flo:3d 0. south step)) + (normalized-3d-cross-product + (flo:3d 0. south step) + (flo:3d step east 0.))))))) + (normalize-3d! n) + (if (flo:< (y n) 0.) (warn "; Normal down:" n)) + n))) + +(define (height-color widget height) + (if (flo:negative? height) + (let* ((min-height (terrain-viewport-min-height widget)) + (-norm (flo:- 1. (flo:/ height min-height)))) + (let #;((r (flo:+ .1 (flo:* -norm .8))) + (g (flo:+ .1 (flo:* -norm .8))) + (b (flo:+ .4 (flo:* -norm .6)))) + ((r (flo:+ .2 (flo:* -norm .6))) + (g (flo:+ .2 (flo:* -norm .6))) + (b (flo:+ .2 (flo:* -norm .8)))) + (color r g b 1.))) + (let* ((max-height (terrain-viewport-max-height widget)) + (norm (flo:/ height max-height))) + (let ((r norm) + (g 1.) + (b 0. #;(flo:* norm .4))) + (color r g b 1.))))) + +(define-integrable (normalized-3d-cross-product v1 v2) + (let ((p (3d-cross-product v1 v2))) + (normalize-3d! p) + p)) + +(define (normalized-vector p0 p1) + (let ((nv (flo:2d (flo:- (x p1) (x p0)) + (flo:- (y p1) (y p0))))) + (normalize-2d! nv) + nv)) + +(define (test-normals) + (let ((correct (flo:3d 0. 1. 0.)) + (computed (normal 1. 0. 1. 1. 1. 1.))) + (if (not (3d-~= computed correct 0.0000000000000005)) + (warn "; normal-test: bad normal 1:" computed correct))) + (let ((correct (let ((a pi/4)) (flo:3d (cos a) (sin a) 0.))) + (computed (normal 1. 0. 1. -1. 0. 0.))) + (if (not (3d-~= computed correct 0.0000000000000005)) + (warn "; normal-test: bad normal 2:" computed correct)))) + +(define-integrable-operator (3d-sum a b) + (flo:3d (flo:+ (x a) (x b)) + (flo:+ (y a) (y b)) + (flo:+ (z a) (z b)))) + +(define-integrable-operator (2d-sum a b) + (flo:2d (flo:+ (x a) (x b)) + (flo:+ (y a) (y b)))) + +(define-integrable-operator (normalize-3d! v) + (let ((l (sqrt (flo:+ + (flo:* (x v) (x v)) + (flo:+ + (flo:* (y v) (y v)) + (flo:* (z v) (z v))))))) + (set-x! v (flo:/ (x v) l)) + (set-y! v (flo:/ (y v) l)) + (set-z! v (flo:/ (z v) l)))) + +(define-integrable-operator (normalize-2d! v) + (let ((l (sqrt (flo:+ (flo:* (x v) (x v)) + (flo:* (y v) (y v)))))) + (set-x! v (flo:/ (x v) l)) + (set-y! v (flo:/ (y v) l)))) + +(define (3d-cross-product v1 v2) + (flo:3d + (flo:- (flo:* (y v1) (z v2)) (flo:* (z v1) (y v2))) + (flo:- (flo:* (z v1) (x v2)) (flo:* (x v1) (z v2))) + (flo:- (flo:* (x v1) (y v2)) (flo:* (y v1) (x v2))))) + +(define (make-heightmap-matrix filename rows columns) + (let ((matrix (flo:vector-cons (fix:* rows columns)))) + (call-with-input-file filename + (lambda (in) + (do ((y 0 (fix:1+ y))) + ((fix:= y rows)) + (do ((x 0 (fix:1+ x))) + ((fix:= x columns)) + (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) 'I 'D)))) + (matrix-set! matrix columns x y height)))))))) + matrix)) + +(define-integrable (matrix-set! m c x y v) + (flo:vector-set! m (fix:+ x (fix:* c y)) v)) + +(define-integrable (matrix-ref m c x y) + (flo:vector-ref m (fix:+ x (fix:* c y)))) + +(define (matrix-min.max matrix rows columns) + (let ((min #f) + (max #f)) + (do ((y 0 (fix:1+ y))) + ((fix:= y rows)) + (do ((x 0 (fix:1+ x))) + ((fix:= x columns)) + (let ((h (matrix-ref matrix columns 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 flo:4d) + +(define-integrable-operator (flo:max a b) + (if (flo:< a b) b a)) + +(define %trace? #t) + +(define (%trace . msg) + (if %trace? (for-each display msg))) \ No newline at end of file -- 2.25.1