From: Matt Birkholz Date: Fri, 8 Jan 2016 19:51:58 +0000 (-0700) Subject: terrain: Fix glx-viewport-draw method. X-Git-Tag: mit-scheme-pucked-9.2.12~374 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=21eb9ea373a37578a9c96a6c9501345da08ae795;p=mit-scheme.git terrain: Fix glx-viewport-draw method. Remove redundant (now incorrect) call to with-glx-widget (i.e. glXMakeCurrent). GL no longer allows recursive locking. Fix %trace to use outf-error instead of generic IO. The latter may suspend-current-thread during a callback. Punt glColorMaterial and much frobbage (e.g. setting params to their defaults) copied from examples. Minimize differences between draw-colored and draw-shaded. --- diff --git a/src/planetarium/Makefile b/src/planetarium/Makefile index e98198f84..96e1210d1 100644 --- a/src/planetarium/Makefile +++ b/src/planetarium/Makefile @@ -22,8 +22,6 @@ exe = '$(MIT_SCHEME_EXE)' --batch-mode all: echo '(load "mit-compile")' | $(exe) - @if [ -s mit-3d-unx.crf ]; then \ - echo "mit-3d-unx.crf:0: error: non-empty"; exit 1; fi check: echo '(load "mit-check")' | $(exe) diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg index 07213c590..b43152fca 100644 --- a/src/planetarium/mit-3d.pkg +++ b/src/planetarium/mit-3d.pkg @@ -39,7 +39,8 @@ USA. 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) + define-class define-method initialize-instance + define-syntax syntax-rules outf-error) (import (gtk) gtk-widget-set-hexpand gtk-widget-set-vexpand diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm index 6c50f6193..8f720a732 100644 --- a/src/planetarium/terrain.scm +++ b/src/planetarium/terrain.scm @@ -159,17 +159,11 @@ USA. (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) + (gl:enable 'DEPTH-TEST) + (gl:enable 'CULL-FACE) ;; 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) @@ -184,12 +178,12 @@ USA. #t) (define-method glx-viewport-draw ((widget )) - (with-glx-widget widget - (lambda () - (gl:call-list (terrain-viewport-mesh widget)))) + (%trace2 "; (glx-viewport-draw )\n") + (gl:call-list (terrain-viewport-mesh widget)) (update-label widget)) (define (update-label widget) + (%trace2 "; update-label\n") (let ((origin (terrain-viewport-origin widget)) (pos (glx-viewport-position widget)) (d/m (flo:/ (terrain-viewport-step-degrees widget) @@ -221,44 +215,41 @@ USA. (define (draw-colored widget) (%trace "; draw-colored "widget"\n") - (let ((step (terrain-viewport-step-meters widget)) - (matrix (terrain-viewport-matrix widget)) + (let ((matrix (terrain-viewport-matrix widget)) (rows (terrain-viewport-rows widget)) - (columns (terrain-viewport-columns widget))) - (let ((-step (flo:- 0. step))) + (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))))) - - (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 (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. - (declare (ignore widget)) - unspecific - #;(let ((rows (terrain-viewport-rows widget)) + (%trace "; draw-sea-level\n") + (let ((rows (terrain-viewport-rows widget)) (columns (terrain-viewport-columns widget)) (step (terrain-viewport-step-meters widget))) (%trace "; disabling LIGHTING\n") @@ -310,17 +301,12 @@ USA. (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:enable 'NORMALIZE) + (%trace "; begin quads\n") (gl:begin 'QUADS) ; or LINES for wireframe (let ((last-row (fix:- rows 2)) (last-column (fix:- columns 2))) @@ -333,8 +319,9 @@ USA. (vertex (fix:1+ x) (fix:1+ y)) (vertex x (fix:1+ y))))) (gl:end) - (gl:disable 'COLOR-MATERIAL) - (draw-sea-level widget))) + (%trace "; end quads\n") + ;;(draw-sea-level widget) + )) (define (normal step height east west north south) (let ((-step (flo:- 0. step))) @@ -479,5 +466,14 @@ USA. (define %trace? #t) -(define (%trace . msg) - (if %trace? (for-each display msg))) \ No newline at end of file +(define-syntax %trace + (syntax-rules () + ((_ . MSG) + (if %trace? ((lambda () (outf-error . MSG))))))) + +(define %trace2? #f) + +(define-syntax %trace2 + (syntax-rules () + ((_ . MSG) + (if %trace2? ((lambda () (outf-error . MSG))))))) \ No newline at end of file