From: Matt Birkholz Date: Sat, 30 Apr 2016 19:49:41 +0000 (-0700) Subject: planetarium/terrain.scm: Produce a properly shaded sample. X-Git-Tag: mit-scheme-pucked-9.2.12~336 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=af449f6c3f795b95232719cde796304afbbe4454;p=mit-scheme.git planetarium/terrain.scm: Produce a properly shaded sample. Set the light position in the draw method. The position is stored in eye coords and must be updated when the eye moves. Use a directional light. Do not cull back faces. Fix normal to use the height change (not absolute height!) to east, west, north and south. Add more normal tests. Fix write-sample-terrain to produce the correct number of samples. Support an optional height->color function. Change height-color to be such a function. Merge draw-colored and draw-shaded into draw-mesh; conditionally use gl:color-material. Fix bounds of data plotted. Since heights adjacent to edges are imagined flat (not undefined), ALL heights can be used to form quads. --- diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm index 52c94011b..e624e4f67 100644 --- a/src/planetarium/terrain.scm +++ b/src/planetarium/terrain.scm @@ -26,8 +26,9 @@ USA. (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) @@ -37,7 +38,6 @@ USA. "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") @@ -70,7 +70,7 @@ USA. (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 "")) @@ -82,8 +82,8 @@ USA. (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) @@ -95,7 +95,7 @@ USA. (define-class ( (constructor make-terrain-viewport (matrix rows columns min-height max-height - origin step-degrees label) + origin step-degrees color-function label) (width height))) () @@ -112,6 +112,7 @@ USA. (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) @@ -124,7 +125,7 @@ USA. ;; 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)) @@ -146,11 +147,7 @@ USA. (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 )) (%trace "; (fix-widget-realize-callback )\n") @@ -161,25 +158,28 @@ USA. ;;(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 )) (%trace2 "; (glx-viewport-draw )\n") + (gl:light 'LIGHT0 'POSITION (terrain-viewport-light-position widget)) (gl:call-list (terrain-viewport-mesh widget)) (update-label widget)) @@ -214,39 +214,6 @@ USA. (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") @@ -278,13 +245,16 @@ USA. (%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))) @@ -297,20 +267,21 @@ USA. #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))) @@ -325,37 +296,32 @@ USA. )) (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)))) @@ -363,8 +329,7 @@ USA. (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))) @@ -375,21 +340,39 @@ USA. (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)) @@ -447,10 +430,12 @@ USA. (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))) @@ -490,7 +475,7 @@ USA. (define-integrable-operator (flo:max a b) (if (flo:< a b) b a)) -(define %trace? #t) +(define %trace? #f) (define-syntax %trace (syntax-rules ()