(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))
(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)))
-\f
-#| Replace gdk_window_new with XCreateWindow, following example of
- <fix-widget>.
-
- (define-class (<glx-widget> (constructor () (width height)))
- (<scm-widget>)
-
- ;; 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 <glx-widget>")
-
- (define-integrable guarantee-size guarantee-non-negative-fixnum)
-
- (define-method initialize-instance ((widget <glx-widget>) width height)
- (call-next-method widget)
- (%trace "; (initialize-instance <glx-widget>) "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 (<glx-widget> (constructor () (width height)))
+(define-class (<glx-widget> (constructor %make-glx-widget () (width height)))
(<fix-widget>)
(xdisplay define standard
(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
#;(define (gl-adjustments-callback widget hGtkAdjustment vGtkAdjustment)
(%trace ";set-scroll-adjustments "widget
" "hGtkAdjustment" "vGtkAdjustment"\n"))
+\f
+(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 (<glx-viewport> (constructor (draw) (width height)))
+ ;; A <glx-widget> 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.
+ (<glx-widget>)
+ (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 <glx-viewport>) 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 <glx-viewport>) key bits)
+ (%trace "; (key-press <glx-viewport>) "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
+++ /dev/null
-#| -*-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-widget> (<fix-widget>)
- (gl-window define standard)
- (context define standard))
-
-(define-method initialize-instance ((widget <gl-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
projects / mit-scheme.git / commitdiff