From 9cd88d844fb73539f380c3e86b2118240bf7ef7b Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 30 Apr 2016 12:38:10 -0700 Subject: [PATCH] gl: Add a popup help window for glx-viewports and glxgears-demos. --- src/gl/gl-glx.scm | 30 ++++++++++++++++------- src/gl/gl-glxgears.scm | 28 +++++++++++++++++++++- src/gl/gl.pkg | 54 ++++++++++++++++++++++++++---------------- 3 files changed, 83 insertions(+), 29 deletions(-) diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index 56675f8dc..a00d62955 100644 --- 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 41b00dc75..be779bc55 100644 --- 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 cb363eac4..344fcd78c 100644 --- 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) + 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-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 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) -- 2.25.1