|#
-(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)
(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))
(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,
;; 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)))
(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
+++ /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.
-;;
-;; 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: <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.")
- 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))))
-\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
|#
-;;;; 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: <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 (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))))
+\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
;;;; 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>
+ 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
;;;; 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
;;;; 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-time<? "mit-3d.pkg" package-set))
+ (cref/generate-trivial-constructor "mit-3d"))
+ (construct-packages-from-file (fasload package-set)))
- (let ((env (->environment '(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
|#
(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-time<? "mit.pkg" package-set))
(cref/generate-trivial-constructor "mit"))
(construct-packages-from-file (fasload package-set))))
- (compile-file "mit-r3rs" '() (->environment '(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
--- /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.
+
+|#
+
+;;;; 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
(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
(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
--- /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 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 (<terrain-viewport>
+ (constructor make-terrain-viewport
+ (matrix rows columns min-height max-height
+ origin step-degrees label)
+ (width height)))
+ (<glx-viewport>)
+
+ ;; 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 <terrain-viewport>) width height)
+ (%trace "; (initialize-instance <terrain-viewport>)\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 <terrain-viewport>))
+ (%trace "; (fix-widget-realize-callback <terrain-viewport>)\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 <terrain-viewport>))
+ (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
projects / mit-scheme.git / commitdiff