gl: Enhance glxgears demo.

Allow FPS rate reporting to be toggled off.  Try to use visibility
notify events to avoid spinning when the display is blanked.  Remove
stereo support.  (Move it to the new <glx-viewport> widget.)

diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm
index c38e19c48d314275a1c6911d2a2c01c777d4d818..25c83fb8c5c62efbddf6b7115d03f53b4a93c02f 100644 (file)
--- a/src/gl/gl-glxgears.scm
+++ b/src/gl/gl-glxgears.scm
@@ -25,7 +25,7 @@ USA.
 
 ;;(declare (no-type-checks) (no-range-checks))
 
-#;(declare (reduce-operator (sin flo:sin)
+(declare (reduce-operator (sin flo:sin)
                          (cos flo:cos)
                          (sqrt flo:sqrt)
                          (= flo:=)
@@ -76,13 +76,19 @@ USA.
 
   (shape define standard initial-value '(0 . 0))
   (mapped? define standard initial-value #f)
-  (animate? define standard initial-value #f)
+  ;; This "visibility" slot was intended to reflect when my screen is
+  ;; blanked, because the animation loop spins up to more than 300fps.
+  ;; (Please help stop the spinning!)  Why so few visibility-notify
+  ;; events from Gtk lately? ?
+  (visibility define standard initial-value #f)
+  (animate? define standard initial-value #t)
   (animation-thread define standard)
   (animation-halt define standard)
   ;; For smooth rotation at any frame rate?
   (frame-start define standard initial-value #f)
 
   ;; For frame rate reports:
+  (report-fps? define standard initial-value #t)
   (frame-count define standard initial-value 0)
   (frame-count-start define standard initial-value #f))
 
@@ -95,11 +101,10 @@ USA.
   (wake-animation-thread widget))
 
 (define (unrealize-callback widget)
-  (for-each display (list "; unrealize-callback"
-                         " "widget" "(gtk-widget-destroyed? widget)"\n"))
+  (%trace "; unrealize-callback "widget" "(gtk-widget-destroyed? widget)"\n")
   ;; Is this necessary when the context is about to be (already?) destroyed?
   #;(let ((gears (glxgears-demo-gears widget)))
-    (with-glx-device widget
+    (with-glx-widget widget
       (lambda ()
        (gl:delete-lists (car gears) 1)
        (gl:delete-lists (cadr gears) 1)
@@ -134,18 +139,36 @@ USA.
 
 (define (visibility-notify-handler widget how)
   (%trace "; visibility-notify-handler "widget" "how"\n")
-  #f)
+  (let ((old (glxgears-demo-visibility widget)))
+    (set-glxgears-demo-visibility! widget how)
+    (if (and (eq? old 'OBSCURED) (not (eq? how 'OBSCURED)))
+       (wake-animation-thread)))
+  #t)
 
 (define (key-press-handler widget key bits)
   (%trace "; key-press-handler "widget" "key" "bits"\n")
   ;;(declare (ignore bits))
   (case key
-    ((#\escape) (gtk-widget-destroy (gtk-widget-parent widget)))
-    ((#\a) (if (glxgears-demo-animate? widget)
-              (set-glxgears-demo-animate?! widget #f)
-              (begin
-                (set-glxgears-demo-animate?! widget #t)
-                (wake-animation-thread widget))))
+    ((#\escape #\q #\Q) (gtk-widget-destroy (gtk-widget-parent widget)))
+    ((#\a #\A)
+     (if (glxgears-demo-animate? widget)
+        (begin
+          (display "; glxgears: animation OFF\n")
+          (set-glxgears-demo-animate?! widget #f))
+        (begin
+          (display "; glxgears: animation ON\n")
+          (set-glxgears-demo-frame-count-start! widget #f)
+          (set-glxgears-demo-animate?! widget #t)
+          (wake-animation-thread widget))))
+    ((#\i #\I)
+     (if (glxgears-demo-report-fps? widget)
+        (begin
+          (display "; glxgears: fps reporting OFF\n")
+          (set-glxgears-demo-report-fps?! widget #f))
+        (begin
+          (display "; glxgears: fps reporting ON\n")
+          (set-glxgears-demo-frame-count-start! widget #f)
+          (set-glxgears-demo-report-fps?! widget #t))))           
     ((|Up|) (rotx! widget 5.) (wake-animation-thread widget))
     ((|Down|) (rotx! widget -5.) (wake-animation-thread widget))
     ((|Left|) (roty! widget 5.) (wake-animation-thread widget))
@@ -178,18 +201,25 @@ USA.
                (set-glxgears-demo-animation-halt! widget halt)
                (let loop ()
 
-                 ;; Sleep when not animate? nor mapped?.
+                 ;; Sleep when not mapped?, not animate?, or obscured.
                  (without-interrupts
                   (lambda ()
-                    (if (or (not (glxgears-demo-mapped? widget))
-                            (not (glxgears-demo-animate? widget)))
-                        (begin
-                          (display ";glxgears: sleeping...\n")
-                          (suspend-current-thread)
-                          (display ";glxgears: ...awake!\n")))))
+                    (let ((visibility (glxgears-demo-visibility widget)))
+                      (if (or (not (glxgears-demo-mapped? widget))
+                              (not (glxgears-demo-animate? widget))
+                              (eq? 'OBSCURED visibility))
+                          (begin
+                            (fresh-line)
+                            (%trace ";glxgears: sleeping")
+                            (if (eq? 'OBSCURED visibility)
+                                (%trace " while obscured"))
+                            (%trace "...\n")
+                            (suspend-current-thread)
+                            (fresh-line)
+                            (%trace ";glxgears: ...awake!\n"))))))
 
                  (if (not (glxgears-demo-mapped? widget))
-                     (display ";glxgears: not mapped\n")
+                     (%trace ";glxgears: not mapped\n")
                      (begin
                        ;; Init, if necessary.
                        (if (not (glxgears-demo-gears widget))
@@ -198,9 +228,8 @@ USA.
                        ;; Draw.
                        (draw-frame widget)))
                  (loop))))
-            (display ";glxgears: done\n")))))
+            (display "; glxgears: done\n")))))
     (set-glxgears-demo-animation-thread! widget thread)
-    (detach-thread thread)
     thread))
 
 (define (wake-animation-thread widget)
@@ -227,32 +256,33 @@ USA.
                                  (let ((dt (if (not start)
                                                0.
                                                (internal-time/ticks->seconds
-                                                (- now start)))))
+                                                (int:- now start)))))
                                    (+ angle (* 70. dt))))
-       (set-glxgears-demo-frame-count! widget (1+ count))))
-  (with-glx-device widget
+       (set-glxgears-demo-frame-count! widget (int:1+ count))))
+  (with-glx-widget widget
     (lambda ()
       (draw widget)
       (%trace ";     swap-buffers\n")
       (glx:swap-buffers widget)
       (%trace ";     flush\n")
       (gl:flush)))
-  (if (glxgears-demo-animate? widget)
+  (if (and (glxgears-demo-animate? widget)
+          (glxgears-demo-report-fps? widget))
       (let ((now (glxgears-demo-frame-start widget))
            (count (glxgears-demo-frame-count widget))
            (start (glxgears-demo-frame-count-start widget)))
        (if start
-           (let ((seconds (internal-time/ticks->seconds (- now start))))
+           (let ((seconds
+                  (->flonum (internal-time/ticks->seconds (fix:- now start)))))
              (if (>= seconds 5.0)
-                 (let ((fps (/ count seconds)))
+                 (let ((fps (/ (->flonum count) seconds)))
                    (define-integrable (%3.1f n)
                      (number->string (/ (round (* 10. n)) 10.)))
                    (define-integrable (%6.3f n)
                      (number->string (/ (round (* 1000. n)) 1000.)))
-                   (for-each display
-                             (list count" frames"
-                                   " in "(%3.1f seconds)" seconds"
-                                   " = "(%6.3f fps)" FPS\n"))
+                   (for-each display (list "; glxgears: "count" frames"
+                                           " in "(%3.1f seconds)" seconds"
+                                           " = "(%6.3f fps)" FPS\n"))
                    (set-glxgears-demo-frame-count-start! widget now)
                    (set-glxgears-demo-frame-count! widget 0))))
            (begin
@@ -268,37 +298,7 @@ USA.
     (let ((gear1 (car gears))
          (gear2 (cadr gears))
          (gear3 (caddr gears)))
-      ;;(if stereo
-         #;(begin
-           ;; First left eye.
-           (gl:draw-buffer 'BACK-LEFT)
-
-           (gl:matrix-mode 'PROJECTION)
-           (gl:load-identity)
-           (gl:frustum left right (- asp) asp 5. 60.)
-
-           (gl:matrix-mode 'MODELVIEW)
-
-           (gl:push-matrix)
-           (gl:translate (* .5 eyesep) 0. 0.)
-           (draw-gears angle gear1 gear2 gear3)
-           (gl:pop-matrix)
-
-           ;; Then right eye.
-           (gl:draw-buffer 'BACK-RIGHT)
-
-           (gl:matrix-mode 'PROJECTION)
-           (gl:load-identity)
-           (gl:frustum (- right) (- left) (- asp) asp 5. 60.)
-
-           (gl:matrix-mode 'MODELVIEW)
-
-           (gl:push-matrix)
-           (gl:translate (* -.5 eyesep) 0. 0.)
-           (draw-gears angle gear1 gear2 gear3)
-           (gl:pop-matrix))
-      (begin
-       (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)))));)
+      (draw-gears angle gear1 gear2 gear3 view-rotx view-roty))))
 
 (define (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)
   (%trace "; draw-gears "angle" "gear1" "gear2" "gear3" "view-rotx" "view-roty"\n")
@@ -337,38 +337,25 @@ USA.
                    (fix:= (cdr w.h) height)))
          (begin
            (%trace ";glxgears: reshape "width" "height" "widget"\n")
-           (with-glx-device widget
+           (with-glx-widget widget
              (lambda ()
                (gl:viewport 0 0 width height)
-               (let ((widthf (->flonum width))
-                     (heightf (->flonum height)))
-               
-                 #;(if stereo
-                 (let ((w (* fix-point (/ 1. 5.))))
-                 (set! asp (/ heightf widthf))
-                 (set! left (* -5. (/ (- w (* .5 eyesep)) fix-point)))
-                 (set! right (* 5. (/ (+ w (* .5 eyesep)) fix-point))))
-                 (let ((h (/ heightf widthf)))
+               (let ((h (/ (->flonum height) (->flonum width))))
                  (gl:matrix-mode 'PROJECTION)
                  (gl:load-identity)
-                 (gl:frustum -1. 1. (- h) h 5. 60.)))
+                 (gl:frustum -1. 1. (- h) h 5. 60.))
 
-                 (let ((h (/ heightf widthf)))
-                   (gl:matrix-mode 'PROJECTION)
-                   (gl:load-identity)
-                   (gl:frustum -1. 1. (- h) h 5. 60.))
-
-                 (gl:matrix-mode 'MODELVIEW)
-                 (gl:load-identity)
-                 (gl:translate 0. 0. -40.))))
+               (gl:matrix-mode 'MODELVIEW)
+               (gl:load-identity)
+               (gl:translate 0. 0. -40.)))
            (set-glxgears-demo-frame-start! widget #f)
            (set-glxgears-demo-frame-count! widget 0)
            (set-glxgears-demo-shape! widget (cons width height)))))))
 
 (define (init widget)
-  (for-each display (list "; glxgears: init "widget"\n"))
+  (%trace "; glxgears: init "widget"\n")
   (reshape widget)
-  (with-glx-device widget
+  (with-glx-widget widget
     (lambda ()
       (let ((pos (flo:4d 5.0 5.0 10.0 0.0))
            (red (color 0.8 0.1 0.0 1.0))
@@ -551,7 +538,9 @@ USA.
 
 (define-integrable color flo:4d)
 
-(define (%trace . msg)
-  (declare (ignore msg))
-  unspecific
-  #;(for-each display msg))
\ No newline at end of file
+(define %trace? #f)
+
+(define-syntax %trace
+  (syntax-rules ()
+    ((_ ARGS ...)
+     (if %trace? (display ARGS ...)))))
\ No newline at end of file