(declare (integrate-external "geometry"))
-(define (make-terrain filename rows columns lat lng step)
- (let ((widget (%make-terrain filename rows columns lat lng step)))
+(define (make-terrain filename rows columns lat lng step color-function)
+ (let ((widget (%make-terrain filename rows columns
+ lat lng step color-function)))
(named-lambda (terrain command . args)
(define (check-flonum-args num description)
"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")
(else
(error:wrong-type-argument command "a command name" 'TERRAIN))))))
-(define (%make-terrain filename rows columns lat lng step)
+(define (%make-terrain filename rows columns lat lng step color-function)
(let ((window (gtk-window-new 'toplevel))
(grid (gtk-grid-new))
(label (gtk-label-new ""))
(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)))
+ (make-latitude/longitude lat lng) step color-function
+ label 300 300)))
(gtk-widget-set-vexpand widget #t)
(gtk-widget-set-hexpand widget #t)
(gtk-grid-attach grid widget 0 0 1 1)
(define-class (<terrain-viewport>
(constructor make-terrain-viewport
(matrix rows columns min-height max-height
- origin step-degrees label)
+ origin step-degrees color-function label)
(width height)))
(<glx-viewport>)
(origin define accessor)
(step-degrees define accessor)
+ (color-function define accessor)
;; A GtkLabel to update with the current lat/lng, heading, and inclination.
(label define accessor)
;; Update LIGHT0 if changing this:
(light-position define accessor
- initializer (lambda () (flo:4d 0. 0. 0. 1.)))
+ initializer (lambda () (flo:4d 1. 1. 1. 0.)))
;; The display-list for the terrain mesh.
(mesh define standard initial-value #f))
(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.)))))))
+ (set-glx-viewport-far! widget 150000.))))))
(define-method fix-widget-realize-callback ((widget <terrain-viewport>))
(%trace "; (fix-widget-realize-callback <terrain-viewport>)\n")
;;(gl:shade-model 'FLAT)
(gl:clear-color (color .527 .805 .977 1.)) ; light sky blue: #x87cefa
(gl:enable 'DEPTH-TEST)
- (gl:enable 'CULL-FACE)
+ ;;(gl:enable 'CULL-FACE)
;; Really Nice Perspective Calculations
(gl:hint 'PERSPECTIVE-CORRECTION 'NICEST)
- (gl:light 'LIGHT0 'POSITION (terrain-viewport-light-position widget))
(gl:light-model 'LOCAL-VIEWER 1.)
(gl:enable 'LIGHTING)
(gl:enable 'LIGHT0)
+ (if (terrain-viewport-color-function widget)
+ (begin
+ (gl:color-material 'FRONT 'DIFFUSE)
+ (gl:enable 'COLOR-MATERIAL)))
(let ((mesh (gl:gen-lists 1)))
(gl:new-list mesh 'COMPILE)
- ;;(draw-colored widget)
- (draw-shaded widget)
+ (draw-mesh widget)
(gl:end-list)
(set-terrain-viewport-mesh! widget mesh))))
#t)
(define-method glx-viewport-draw ((widget <terrain-viewport>))
(%trace2 "; (glx-viewport-draw <terrain-viewport>)\n")
+ (gl:light 'LIGHT0 'POSITION (terrain-viewport-light-position widget))
(gl:call-list (terrain-viewport-mesh widget))
(update-label widget))
(radians->degrees (glx-viewport-tilt widget))) '(int))
"°"))))
-(define (draw-colored widget)
- (%trace "; draw-colored "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)))
- (gl:color (height-color widget h))
- (gl:vertex (flo:3d (flo:* (->flonum x) step)
- h
- (flo:* (->flonum y) -step)))))
-
- (%trace "; begin quads\n")
- (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))
- (vertex x y)
- (vertex (fix:1+ x) y)
- (vertex (fix:1+ x) (fix:1+ y))
- (vertex x (fix:1+ y))
- )))
- (gl:end)
- (%trace "; end quads\n")
- ;;(draw-sea-level widget)
- ))
-
(define (draw-sea-level widget)
;; A translucent blue plane at sea level.
(%trace "; draw-sea-level\n")
(%trace "; enabling LIGHTING\n")
(gl:enable 'LIGHTING)))
-(define (draw-shaded widget)
- (%trace "; draw-shaded "widget"\n")
+(define (draw-mesh widget)
+ (%trace "; draw-mesh "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))))
+ (-step (flo:- 0. (terrain-viewport-step-meters widget)))
+ (color-function (terrain-viewport-color-function widget))
+ (min-height (terrain-viewport-min-height widget))
+ (max-height (terrain-viewport-max-height widget)))
(define (vertex x y)
(let ((h (matrix-ref matrix columns x y)))
#f
(matrix-ref matrix columns x y)))
+ (if color-function
+ (gl:color (color-function h min-height max-height)))
(gl:normal (normal step h
- (ref (fix:-1+ x) y) ; east
- (ref (fix:1+ x) y) ; west
+ (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:vertex (flo:3d (flo:* (->flonum x) step)
h
(flo:* (->flonum y) -step)))))
- (gl:enable 'NORMALIZE)
(%trace "; begin quads\n")
(gl:begin 'QUADS) ; or LINES for wireframe
- (let ((last-row (fix:- rows 2))
- (last-column (fix:- columns 2)))
+ (let ((last-row (fix:- rows 1))
+ (last-column (fix:- columns 1)))
(do ((y 0 (fix:1+ y)))
((fix:= y last-row))
(do ((x 0 (fix:1+ x)))
))
(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 ((-step (flo:- 0. step))
+ (east (if (not east) 0. (flo:- east height)))
+ (west (if (not west) 0. (flo:- west height)))
+ (north (if (not north) 0. (flo:- north height)))
+ (south (if (not south) 0. (flo:- 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.)))))))
+ (flo:3d step east 0.)
+ (flo:3d 0. north -step))
+ (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)
+(define (height-color height min max)
(if (flo:negative? height)
- (let* ((min-height (terrain-viewport-min-height widget))
- (-norm (flo:- 1. (flo:/ height min-height))))
+ (let ((-norm (flo:- 1. (flo:/ height min))))
(let #;((r (flo:+ .1 (flo:* -norm .8)))
(g (flo:+ .1 (flo:* -norm .8)))
(b (flo:+ .4 (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 ((norm (flo:/ height max)))
(let ((r norm)
(g 1.)
(b 0. #;(flo:* norm .4)))
(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))))
+ (let ((n 1))
+
+ (define (test correct computed)
+ #;(for-each display
+ `("; Normal test ",n":\n"
+ "computed:",computed"\n"
+ " correct:",correct"\n"))
+ (if (not (3d-~= computed correct 5.e-16))
+ (warn "; Normal test failed:" n computed correct))
+ (set! n (1+ n)))
+
+ (test (flo:3d 0. 1. 0.)
+ (normal 1. 0. 1. 1. 1. 1.))
+ (test (flo:3d 0. 1. 0.)
+ (normal 1. 1. 0. 0. 0. 0.))
+ (test (flo:3d (- (cos pi/4)) (sin pi/4) 0.)
+ (normal 1. 0. 1. -1. 0. 0.))
+ (test (flo:3d (cos pi/4) (sin pi/4) 0.)
+ (normal 1. 0. -1. 1. 0. 0.))
+ (test (flo:3d 0. (sin pi/4) (- (cos pi/4)))
+ (normal 1. 0. 0. 0. -1. 1.))
+ (test (flo:3d 0. (sin pi/4) (- (cos pi/4)))
+ (normal 1. 0. 1. 1. -1. 1.))
+ (test (flo:3d 0. (sin pi/4) (- (cos pi/4)))
+ (normal 1. 0. -1. -1. -1. 1.))
+ (test (flo:3d 0. (sin pi/4) (cos pi/4))
+ (normal 1. 0. 0. 0. 1. -1.))
+ (test (flo:3d 0. (sin pi/4) (cos pi/4))
+ (normal 1. 0. 1. 1. 1. -1.))
+ (test (flo:3d 0. (sin pi/4) (cos pi/4))
+ (normal 1. 0. -1. -1. 1. -1.))
+ ))
(define-integrable-operator (3d-sum a b)
(flo:3d (flo:+ (x a) (x b))
(y-min -2) (y-max 2))
(let ((x-step (/ (- x-max x-min) x-samples))
(y-step (/ (- y-max y-min) y-samples)))
- (do ((x x-min (+ x x-step)))
- ((> x x-max))
- (do ((y y-min (+ y y-step)))
- ((> y y-max))
+ (do ((x x-min (+ x x-step))
+ (n 0 (fix:1+ n)))
+ ((fix:= n x-samples))
+ (do ((y y-min (+ y y-step))
+ (n 0 (fix:1+ n)))
+ ((fix:= n y-samples))
(write-string time-string)
(write-char #\tab)
(write-string (number->string x '(fix 3)))
(define-integrable-operator (flo:max a b)
(if (flo:< a b) b a))
-(define %trace? #t)
+(define %trace? #f)
(define-syntax %trace
(syntax-rules ()
projects / mit-scheme.git / commitdiff