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 e98198f84ac16608b96e66fcbfc4bd792626b249..96e1210d18fa903b93792e2c867da7313b02938d 100644 (file)
--- 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 07213c5906174ad4eb70091681189375ee8aaa1d..b43152fca12c26bca51de658824e6707f2ca7776 100644 (file)
--- 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 6c50f6193b88bf793e1f466d781942a0a9425bf4..8f720a7324d412ddb8304915eff1778198bee9c3 100644 (file)
--- 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 <terrain-viewport>))
-  (with-glx-widget widget
-    (lambda ()
-      (gl:call-list (terrain-viewport-mesh widget))))
+  (%trace2 "; (glx-viewport-draw <terrain-viewport>)\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