gl: Add a popup help window for glx-viewports and glxgears-demos.

diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index 56675f8dcabdc21a27903f10b184c9aa2e901ada..a00d62955bc0b5d284ffb06e66995e6b06a569bb 100644 (file)
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -291,8 +291,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                                 (loop p)
                                 w))))
      #t)
-    ((#\? #\c-h)
-     (popup-help widget))
+    ((#\? #\h #\H #\c-h |F1|)
+     (popup-help widget)
+     #t)
     ((|Up|)
      (cond ((fix:= bits char-bit:control) (tilt! widget 5.))
           ((fix:= bits 0) (step! widget 1.))
@@ -346,14 +347,27 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (gtk-widget-queue-draw widget)
   #t)
 
+(define help-window #f)
+
 (define (popup-help widget)
-  ;; For now, just write to stdout.
   (declare (ignore widget))
-  (display "ESC - quit
-Up/Down - move forward/backward
-Left/Right - turn left/right
-Ctrl-Up/Down - tilt up/down\n")
-  #t)
+  (if (or (not help-window)
+         (gtk-widget-destroyed? help-window))
+      (let ((window (gtk-window-new 'toplevel))
+           (label (gtk-label-new
+                   "Key - Viewport command
+ESC - Quit.
+Up/Down - Move forward/backward.
+Left/Right - Turn left/right.
+Ctrl-Up/Down - Tilt up/down.")))
+       (gtk-window-set-type-hint window 'utility)
+       (gtk-window-set-accept-focus window #f)
+       (gtk-window-set-title window "Help")
+       (gtk-container-set-border-width window 20)
+       (gtk-container-add window label)
+       (set! help-window window)
+       (gtk-widget-show-all window)))
+  (gtk-window-present help-window))
 
 (define-integrable (flo:3d x y z)
   (let ((v (flo:vector-cons 3)))

diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm
index 41b00dc75b4a42ef4067ef9e4ee69374077fd60d..be779bc55054865da5d51c30a8f76c7358791678 100644 (file)
--- a/src/gl/gl-glxgears.scm
+++ b/src/gl/gl-glxgears.scm
@@ -150,7 +150,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (%trace "key-press-handler "widget" "key" "bits)
   ;;(declare (ignore bits))
   (case key
-    ((#\escape #\q #\Q) (gtk-widget-destroy (gtk-widget-parent widget)))
+    ((#\escape #\q #\Q)
+     (gtk-widget-destroy (gtk-widget-parent widget)))
+    ((#\? #\h #\H #\c-h |F1|)
+     (popup-help widget)
+     #t)
     ((#\a #\A)
      (if (glxgears-demo-animate? widget)
         (begin
@@ -184,6 +188,28 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (set-glxgears-demo-view-roty!
    widget (+ incr (glxgears-demo-view-roty widget))))
 
+(define help-window #f)
+
+(define (popup-help widget)
+  (declare (ignore widget))
+  (if (or (not help-window)
+         (gtk-widget-destroyed? help-window))
+      (let ((window (gtk-window-new 'toplevel))
+           (label (gtk-label-new
+                   "Key - GLX Gears demo command.
+ESC - Quit.
+Up/Down/Left/Right - Orbit.
+A - Toggle animation.
+I - Toggle frame rate reports.")))
+       (gtk-window-set-type-hint window 'utility)
+       (gtk-window-set-accept-focus window #f)
+       (gtk-window-set-title window "Help")
+       (gtk-container-set-border-width window 20)
+       (gtk-container-add window label)
+       (set! help-window window)
+       (gtk-widget-show-all window)))
+  (gtk-window-present help-window))
+
 (define (motion-handler widget modifiers x y)
   (%trace2 "motion-handler "widget" "modifiers" "x"x"y)
   #f)

diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg
index cb363eac48359e7896e75062860c3c7eec525eb5..344fcd78cc17618bce057588a7c43dc7d15e4e90 100644 (file)
--- a/src/gl/gl.pkg
+++ b/src/gl/gl.pkg
@@ -93,21 +93,26 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
          fix-rect-x fix-rect-y fix-rect-width fix-rect-height
          fix-widget-geometry fix-widget-window)
   (import (gtk)
+         <fix-widget>
          error-if-null
-         gtk-window-new
-         gtk-widget-destroy gtk-widget-parent
-         gtk-widget-show-all
-         gtk-widget-queue-draw
-         set-gtk-widget-draw-callback!
-         gtk-window-set-title
-         set-gtk-window-delete-event-callback!
-         gtk-container-set-border-width
+         fix-widget-new-geometry-callback
+         fix-widget-realize-callback
          gtk-container-add
+         gtk-container-set-border-width
+         gtk-label-new
+         gtk-widget-destroy
+         gtk-widget-destroyed?
+         gtk-widget-parent
+         gtk-widget-queue-draw
          gtk-widget-show-all
-         <fix-widget>
-         fix-widget-realize-callback
-         fix-widget-new-geometry-callback
-         set-fix-widget-key-press-handler!)
+         gtk-window-new
+         gtk-window-present
+         gtk-window-set-accept-focus
+         gtk-window-set-title
+         gtk-window-set-type-hint
+         set-fix-widget-key-press-handler!
+         set-gtk-widget-draw-callback!
+         set-gtk-window-delete-event-callback!)
   (export (gl)
          make-glx-widget <glx-widget>
          with-glx-widget glx:swap-buffers
@@ -127,22 +132,31 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (files "gl-glxgears")
   (parent (gl))
   (import (gtk)
-         gtk-widget-destroyed? gtk-widget-destroy
-         gtk-widget-parent gtk-widget-show-all gtk-widget-queue-draw
-         set-gtk-widget-draw-callback!
-         gtk-container-add gtk-container-set-border-width
-         gtk-window-new gtk-window-set-title
-         set-gtk-window-delete-event-callback!
          fix-widget-new-geometry-callback
          fix-widget-realize-callback
          fix-widget-unrealize-callback
-         set-fix-widget-key-press-handler!
+         gtk-container-add
+         gtk-container-set-border-width
+         gtk-label-new
+         gtk-widget-destroy
+         gtk-widget-destroyed?
+         gtk-widget-parent
+         gtk-widget-queue-draw
+         gtk-widget-show-all
+         gtk-window-new
+         gtk-window-present
+         gtk-window-set-accept-focus
+         gtk-window-set-title
+         gtk-window-set-type-hint
          set-fix-widget-button-handler!
          set-fix-widget-enter-notify-handler!
          set-fix-widget-focus-change-handler!
+         set-fix-widget-key-press-handler!
          set-fix-widget-leave-notify-handler!
          set-fix-widget-motion-handler!
-         set-fix-widget-visibility-notify-handler!)
+         set-fix-widget-visibility-notify-handler!
+         set-gtk-widget-draw-callback!
+         set-gtk-window-delete-event-callback!)
   (import (gtk fix-layout)
          fix-rect-width fix-rect-height
          fix-widget-geometry)