From: Matt Birkholz Date: Sun, 3 Nov 2013 23:51:41 +0000 (-0700) Subject: gl: with-glx-viewport, with-glx-widget X-Git-Tag: mit-scheme-pucked-9.2.12~438 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f63d2fae987b6f9bd34acdd7a83a03ab81dd681a;p=mit-scheme.git gl: with-glx-viewport, with-glx-widget with-glx-device is now with-glx-widget. The new takes a draw procedure and provides key-press handling that allows the arrow keys to orbit the view around the origin. --- diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index 62d5a12b6..6184a3afb 100644 --- a/src/gl/gl-glx.scm +++ b/src/gl/gl-glx.scm @@ -26,19 +26,18 @@ USA. (C-include "gl") -(define (make-glx-device width height title) +(define (make-glx-widget width height title) (let ((window (gtk-window-new 'toplevel))) - (gtk-window-set-opacity window 1.0) (gtk-window-set-title window title) (set-gtk-window-delete-event-callback! window (lambda (w) (%trace ";closed "w"\n") 0)) (gtk-container-set-border-width window 5) - (let ((widget (make-glx-widget width height))) + (let ((widget (%make-glx-widget width height))) (gtk-container-add window widget) (gtk-widget-show-all window) widget))) -(define (with-glx-device widget thunk) +(define (with-glx-widget widget thunk) (with-gl-library (lambda () (let ((xdisplay (glx-widget-xdisplay widget)) @@ -54,161 +53,10 @@ USA. (define (glx:swap-buffers widget) (let ((xdisplay (glx-widget-xdisplay widget)) (xwindow (glx-widget-xwindow widget))) - (%trace2 "; glx:swap-buffers "xdisplay" "xwindow"\n") + (%trace "; glx:swap-buffers "xdisplay" "xwindow"\n") (C-call "glXSwapBuffers" xdisplay xwindow))) - -#| Replace gdk_window_new with XCreateWindow, following example of - . - - (define-class ( (constructor () (width height))) - () - - ;; Our xwindow. Until realized, a NULL pointer. - (xwindow define accessor - initializer (lambda () (make-alien '|Window|))) - - ;; Our window geometry (allocation) -- a rectangular extent in - ;; fixnum device coordinates (e.g. size in pixels, offset within - ;; parent window [ancestor widget]). - (geometry define accessor initializer (lambda () (make-fix-rect))) - - (event-handlers define accessor initializer - (lambda () (make-vector (C-enum "GDK_DAMAGE") #f))) - - ;; Used by glXfunctions. - (display define standard - initializer (lambda () (make-alien '|Display|))) - (glxwindow define standard - ;; This alien's address is the GLXWindow XID. - initializer (lambda () (make-alien 'XID))) - (glxcontext define standard - initializer (lambda () (make-alien '(struct |__GLXcontextRec|))))) - - (define-guarantee glx-widget "a ") - - (define-integrable guarantee-size guarantee-non-negative-fixnum) - - (define-method initialize-instance ((widget ) width height) - (call-next-method widget) - (%trace "; (initialize-instance ) "widget" "width"x"height"\n") - (set-scm-widget-natural-size! widget width height) - ;; Init. size, for a realize signal arriving before an allocation. - (flo:vector-set! (glx-widget-geometry widget) 2 width) - (flo:vector-set! (glx-widget-geometry widget) 3 height) - (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1) - (set-gtk-widget-realize-callback! widget glx-widget-realize-callback) - (set-gtk-widget-size-allocate-callback! widget glx-widget-allocate-callback) - (set-gtk-widget-event-callback! widget glx-widget-event-callback)) - - (define (glx-widget-realize-callback widget) - (%trace "; glx-widget-realize-callback "widget"\n") - (let* ((GtkWidget (gobject-alien widget)) - (parent-GdkWindow - (C-call "gtk_widget_get_parent_window" (make-alien '|GdkWindow|) - GtkWidget))) - (error-if-null parent-GdkWindow "Could not get parent:" widget) - - ;; Create widget xwindow. - (let* ((display (C-call "gdk_window_xdisplay" (make-alien '|Display|) - parent-GdkWindow)) - (screen-num (C-call "gdk_window_screen_num" parent-GdkWindow)) - #;(fb-configs (or (choose-fb-config - display screen-num - (list (C-enum "GLX_DEPTH_SIZE") - 1 - (C-enum "GLX_DOUBLEBUFFER") - (C-enum "GLX_NONE"))) - (choose-fb-config - display screen-num - (list (C-enum "GLX_DEPTH_SIZE") - 1 - (C-enum "GLX_NONE"))) - (error "Could not find suitable GLXFBConfigs."))) - #;(fb-config (C-> fb-configs "GLXFBConfig" - (make-alien '(struct |__GLXFBConfigRec|)))) - (parent-Window (C-call "gdk_window_Window" parent-GdkWindow)) - (attribs (make-attribs - `( - ;; Singleton attributes. - ,(C-enum "GLX_RGBA") - ,(C-enum "GLX_DOUBLEBUFFER") - - ;; Key/value attributes. - ,(C-enum "GLX_RED_SIZE") 1 - ,(C-enum "GLX_GREEN_SIZE") 1 - ,(C-enum "GLX_BLUE_SIZE") 1 - ,(C-enum "GLX_DEPTH_SIZE") 1 - - ,(C-enum "None")))) - (visinfo (C-call "glXChooseVisual" (make-alien '|XVisualInfo|) - display screen-num attribs))) - #;(xfree fb-configs) - (free attribs) - (let ((visual #;(let ((alien (malloc (C-sizeof "int") 'int))) - (C-call "glXGetFBConfigAttrib" display fb-config - (C-enum "GLX_VISUAL_ID") alien) - (let ((value (C-> alien "int"))) - (free alien) - value)) - (C-> visinfo "XVisualInfo visual")) - (depth #;(... (C-call "glXGetFBConfigAttrib"... - "GLX_VISUAL_DEPTH"???...)... ) - (C-> visinfo "XVisualInfo depth")) - (geometry (glx-widget-geometry widget)) - (attr (malloc (C-sizeof "XSetWindowAttributes") - '|XSetWindowAttributes|)) - (xwindow (glx-widget-xwindow widget)) - (mask (bit-ior (C-enum "CWBackPixel") - (C-enum "CWBorderPixel") - (C-enum "CWColormap") - (C-enum "CWEventMask")))) - (C->= attr "XSetWindowAttributes background_pixel" 0) - (C->= attr "XSetWindowAttributes border_pixel" 0) - (let ((colormap (C-call "XCreateColormap" display parent-Window - visual (C-enum "AllocNone")))) - (%trace ";XCreateColormap => "colormap"\n") - (C->= attr "XSetWindowAttributes colormap" colormap)) - (C->= attr "XSetWindowAttributes event_mask" - (bit-ior (C-enum "StructureNotifyMask") - (C-enum "ExposureMask") - (C-enum "KeyPressMask") - #;ALL-EVENTS-AND-DELIVERED-HOW???)) - (let ((win (C-call "x_create_window" display root - (fix-rect-x geometry) - (fix-rect-y geometry) - (fix-rect-width geometry) - (fix-rect-height geometry) - 0 ;pixmap - depth - (C-enum "InputOutput") ;type - visual - mask - attr))) - (%trace ";XCreateWindow => "win"\n") - (error-if-null win "Could not create GLX window:" widget) - ;;(C-call "gtk_widget_set_window" GtkWidget main-GdkWindow) - ;;(C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) - (%trace "; xwindow: "win"\n")))) - - (define (allocate-callback widget GtkAllocation) - (let ((x (C-> GtkAllocation "GtkAllocation x")) - (y (C-> GtkAllocation "GtkAllocation y")) - (width (C-> GtkAllocation "GtkAllocation width")) - (height (C-> GtkAllocation "GtkAllocation height")) - (rect (gtk-widget-geometry widget))) - (%trace "; allocated "width"x"height" at "x","y" for "widget"\n") - (C-call "gtk_widget_set_allocation" (gobject-alien widget) GtkAllocation) - (set-fix-rect! rect x y width height) - (if (gtk-widget-realized? widget) - (C-call "gdk_window_move_resize" - (gtk-widget-window widget) - x y width height)))) - - (define (gtk-widget-realized? widget) - (not (alien-null? (gtk-widget-window widget)))) -|# -(define-class ( (constructor () (width height))) +(define-class ( (constructor %make-glx-widget () (width height))) () (xdisplay define standard @@ -226,9 +74,9 @@ USA. (C-call "gtk_widget_set_double_buffered" alien 0) (C-call "gtk_widget_set_app_paintable" alien 1))) -(define (make-glx-widget-cleanup display context) +(define (make-glx-widget-cleanup xdisplay glxcontext) (named-lambda (glx-widget-cleanup) - (cleanup-glx-widget display context))) + (cleanup-glx-widget xdisplay glxcontext))) (define (cleanup-glx-widget xdisplay glxcontext) ;;without-interrupts @@ -377,10 +225,144 @@ USA. #;(define (gl-adjustments-callback widget hGtkAdjustment vGtkAdjustment) (%trace ";set-scroll-adjustments "widget " "hGtkAdjustment" "vGtkAdjustment"\n")) + +(define (with-glx-viewport width height title draw) + (let ((window (gtk-window-new 'toplevel))) + (gtk-window-set-title window title) + (set-gtk-window-delete-event-callback! + window (lambda (w) (%trace ";closed "w"\n") 0)) + (gtk-container-set-border-width window 5) + (let ((widget (make-glx-viewport draw width height))) + (gtk-container-add window widget) + (gtk-widget-show-all window) + widget))) -(define (%trace . objects) - (for-each display objects)) +(define-class ( (constructor (draw) (width height))) + ;; A with viewport parameters, thus implementing + ;; scrolling -- "orbiting" the viewport around a focus. It also + ;; supports stereo views and provides a key-press handler that + ;; orbits with the arrow keys. + () + (stereo? define standard) + (eye-separation define standard initial-value 5.) + (fixation-distance define standard initial-value 40.) + (x-rotation define standard initial-value 20.) + (y-rotation define standard initial-value 30.) + (draw define accessor)) + +(define-method initialize-instance ((widget ) width height) + (call-next-method widget width height) -(define (%trace2 . objects) - (declare (ignore objects)) - unspecific) \ No newline at end of file + (set-glx-viewport-stereo?! widget #f) ;How to tell if display is stereo? + (set-gtk-widget-draw-callback! widget draw) + (set-fix-widget-key-press-handler! widget glx-viewport-key-press-handler)) + +(define (draw widget cr) + (declare (ignore cr)) + (%trace "; draw "widget"\n") + (with-glx-widget widget + (lambda () + (let ((geometry (fix-widget-geometry widget)) + (rotx (glx-viewport-x-rotation widget)) + (roty (glx-viewport-y-rotation widget)) + (DRAW (glx-viewport-draw widget))) + (let ((width (fix-rect-width geometry)) + (height (fix-rect-height geometry))) + (gl:viewport 0 0 width height) + (let ((aspect (->flonum (/ width height)))) + (if (glx-viewport-stereo? widget) + (let ((eyesep (glx-viewport-eye-separation widget)) + (fix-point (glx-viewport-fixation-distance widget))) + (let ((w (* fix-point (/ 1. 5.)))) + (let ((left (* -5. (/ (- w (* .5 eyesep)) fix-point))) + (right (* 5. (/ (+ w (* .5 eyesep)) fix-point)))) + + ;; First left eye. + (gl:draw-buffer 'BACK-LEFT) + + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum left right (- aspect) aspect -1. 1.) + + (gl:matrix-mode 'MODELVIEW) + (gl:push-matrix) + (gl:translate (* .5 eyesep) 0. -2.) + (gl:rotate rotx 1. 0. 0.) + (gl:rotate roty 0. 1. 0.) + (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) + (DRAW widget) + (gl:pop-matrix) + + ;; Then right eye. + (gl:draw-buffer 'BACK-RIGHT) + + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum (- right) (- left) (- aspect) aspect -1. 1.) + + (gl:matrix-mode 'MODELVIEW) + (gl:push-matrix) + (gl:translate (* -.5 eyesep) 0. -2.) + (gl:rotate rotx 1. 0. 0.) + (gl:rotate roty 0. 1. 0.) + (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) + (DRAW widget) + (gl:pop-matrix)))) + + (begin + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum -1. 1. (- aspect) aspect -1. 1.) + (gl:rotate rotx 1. 0. 0.) + (gl:rotate roty 0. 1. 0.) + + (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) + (gl:matrix-mode 'MODELVIEW) + (gl:load-identity) + (gl:push-matrix) + (DRAW widget) + (gl:pop-matrix)))))) + (glx:swap-buffers widget) + (gl:flush) + #t))) + +(define-generic glx-viewport-key-press-handler (widget key bits)) + +(define-method glx-viewport-key-press-handler ((widget ) key bits) + (%trace "; (key-press ) "widget" "key" "bits"\n") + (case key + ((#\escape #\Q #\q) (gtk-widget-destroy (gtk-widget-parent widget)) #t) + ((#\? #\c-h) (popup-help widget)) + ((|Up|) (rotx! widget 5.)) + ((|Down|) (rotx! widget -5.)) + ((|Left|) (roty! widget 5.)) + ((|Right|) (roty! widget -5.)))) + +(define-integrable (rotx! widget incr) + (set-glx-viewport-x-rotation! + widget (+ incr (glx-viewport-x-rotation widget))) + (gtk-widget-queue-draw widget) + #t) + +(define-integrable (roty! widget incr) + (set-glx-viewport-y-rotation! + widget (+ incr (glx-viewport-y-rotation widget))) + (gtk-widget-queue-draw widget) + #t) + +(define (popup-help widget) + ;; For now, just write to stdout. + (declare (ignore widget)) + (display "ESC - quit +up arrow - move viewport up +down arrow - move viewport down +left arrow - move viewport left +right arrow - move viewport right\n") + #t) + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ ARGS ...) + (if %trace? (outf-error ARGS ...))))) \ No newline at end of file diff --git a/src/gl/gl-gtkglext.scm b/src/gl/gl-gtkglext.scm deleted file mode 100644 index d34e1ce15..000000000 --- a/src/gl/gl-gtkglext.scm +++ /dev/null @@ -1,134 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 2013 Matthew Birkholz - -This file is part of an extension to MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; A few gtkglext wraps. -;;; package: (gl gtk) - -(define (make-gl-device width height) - (let ((window (gtk-window-new 'toplevel))) - (gtk-window-set-opacity window 1.0) - (gtk-window-set-title window "google-elevations") - (set-gtk-window-delete-event-callback! - window (lambda (w) (%trace ";closed "w"\n") 0)) - (gtk-container-set-border-width window 5) - (let ((widget (make-gl-widget width height))) - (gtk-container-add window widget) - (gtk-widget-show-all window) - widget))) - -(C-include "gtkglext") - -(define (with-gl-device widget thunk) - (with-gl-library - (lambda () - (let ((drawable (gl-widget-gl-window widget)) - (context (gl-widget-context widget))) - (if (zero? (C-call "gdk_gl_drawable_gl_begin" drawable context)) - (error "gdk_gl_drawable_gl_begin failed")) - (let ((value (thunk))) - (C-call "gdk_gl_drawable_gl_end" drawable) - value))))) - -(define initted? #f) -(define gdk-gl-config) -(define double-buffered?) - -(define (gtk-gl-init) - (if (not initted?) - (let* ((size (+ (C-sizeof "int") (C-sizeof "* char"))) - (bytes (malloc size #f)) - (count-var bytes) - (vector-var (alien-byte-increment count-var (C-sizeof "int")))) - (C->= count-var "int" 0) - (C->= vector-var "* char" 0) - (if (zero? (C-call "gtk_gl_init_check" count-var vector-var)) - (error "gtk_gl_init_check failed.")) - (free bytes) - (set! gdk-gl-config - (let ((alien (make-alien '|GdkGLConfig|))) - (C-call "gdk_gl_config_new_by_mode" - alien (+ (C-enum "GDK_GL_MODE_RGBA") - (C-enum "GDK_GL_MODE_DEPTH") - (C-enum "GDK_GL_MODE_DOUBLE"))) - (if (alien-null? alien) - (begin - (C-call "gdk_gl_config_new_by_mode" - alien (+ (C-enum "GDK_GL_MODE_RGBA") - (C-enum "GDK_GL_MODE_DEPTH"))) - (if (alien-null? alien) - (error "Could not find an GL-capable visual.")) - (set! double-buffered? #f) - alien) - (begin - (set! double-buffered? #t) - alien)))) - (set! initted? #t)))) - -(define (initialize-package!) - (reset-gl-config) - (add-event-receiver! event:after-restore reset-gl-config)) - -(define (reset-gl-config) - (set! initted? #f) - (set! gdk-gl-config) - (set! double-buffered?)) - -(define-class () - (gl-window define standard) - (context define standard)) - -(define-method initialize-instance ((widget ) width height) - (call-next-method widget width height) - (gtk-gl-init) - (let ((alien (gobject-alien widget))) - (let ((gl-window (make-alien '|GdkGLWindow|)) - (gl-context (make-alien '|GdkGLContext|))) - - (C-call "gtk_widget_set_gl_capability" gl-window - alien gdk-gl-config 0 double-buffered? (C-enum "GDK_GL_RGBA_TYPE")) - (if (alien-null? gl-window) - (error "gdk_window_set_gl_capability failed") - (set-gl-widget-gl-window! widget gl-window)) - - (C-call "gtk_widget_get_gl_context" gl-context alien) - (set-gl-widget-context! widget gl-context)) - #;(set-gtk-widget-draw-callback! widget gl-draw-callback) - #;(set-scm-widget-set-scroll-adjustments-callback! widget - gl-adjustments-callback) - (C-call "gtk_widget_set_can_focus" alien 1))) - -#;(define (gl-draw-callback widget cairo) - (%trace "; draw "widget" at " - (cairo-clip-extents - cr (lambda (min-x min-y max-x max-y) - (define-integrable n->s number->string) - (string-append (n->s min-x)","(n->s min-y) - " "(n->s (- max-x min-x)) - "x"(n->s (- max-y min-y))))) - "\n")) - -#;(define (gl-adjustments-callback widget hGtkAdjustment vGtkAdjustment) - (%trace ";set-scroll-adjustments "widget - " "hGtkAdjustment" "vGtkAdjustment"\n")) - -#;(define (%trace . objects) (for-each display objects)) \ No newline at end of file