gtk: first cut at gl support

collects/mred/private/kernel.rkt

@@ -5,25 +5,20 @@
          "wx/common/queue.rkt"
          "wx/common/clipboard.rkt"
          "wx/common/cursor.rkt"
-         "wx/common/gl-config.rkt"
          "wx/common/procs.rkt"
          "wx/common/handlers.rkt"
          racket/class
          racket/draw)
 
-(define gl-context<%> (class->interface gl-context%))
-
 (define (key-symbol-to-integer k)
   (error 'key-symbol-to-integer "not yet implemented"))
 
 (provide (all-from-out "wx/platform.rkt")
          clipboard<%>
-         gl-context<%>
          (all-from-out "wx/common/event.rkt"
                        "wx/common/timer.rkt"
                        "wx/common/clipboard.rkt"
                        "wx/common/cursor.rkt"
-                       "wx/common/gl-config.rkt"
                        "wx/common/procs.rkt")
          (all-from-out racket/draw)
 

collects/mred/private/wx/cocoa/platform.rkt

@@ -37,7 +37,6 @@
    dialog%
    frame%
    gauge%
-   gl-context%
    group-panel%
    item%
    list-box%

collects/mred/private/wx/common/gl-config.rkt

@@ -1,20 +0,0 @@
-#lang scheme/base
-(require scheme/class
-          "../../syntax.rkt")
-
-(provide gl-config%)
-
-(defclass gl-config% object%
-  (def/public-unimplemented get-double-buffered)
-  (def/public-unimplemented set-double-buffered)
-  (def/public-unimplemented get-stereo)
-  (def/public-unimplemented set-stereo)
-  (def/public-unimplemented get-stencil-size)
-  (def/public-unimplemented set-stencil-size)
-  (def/public-unimplemented get-accum-size)
-  (def/public-unimplemented set-accum-size)
-  (def/public-unimplemented get-depth-size)
-  (def/public-unimplemented set-depth-size)
-  (def/public-unimplemented get-multisample-size)
-  (def/public-unimplemented set-multisample-size)
-  (super-new))

collects/mred/private/wx/gtk/canvas.rkt

@@ -186,7 +186,7 @@
            x y w h
            style
            [ignored-name #f]
-           [gl-config #f])
+           [gl-conf #f])
 
      (inherit get-gtk set-size get-size get-client-size 
               on-size get-top-win
@@ -337,6 +337,9 @@
      (define/override (get-client-gtk) client-gtk)
      (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
 
+     (define gl-config gl-conf)
+     (define/public (get-gl-config) gl-config)
+
      (define/override (get-client-delta)
        (values margin margin))
 

collects/mred/private/wx/gtk/dc.rkt

@@ -6,6 +6,7 @@
          "window.rkt"
          "x11.rkt"
          "win32.rkt"
+         "gl-context.rkt"
 	 "../../lock.rkt"
          "../common/backing-dc.rkt"
          racket/draw/cairo
@@ -82,6 +83,13 @@
 
     (super-new)
 
+    (define gl #f)
+    (define/override (get-gl-context)
+      (or gl
+          (create-widget-gl-context
+           (send canvas get-client-gtk)
+           (send canvas get-gl-config))))
+
     (define/override (make-backing-bitmap w h)
       (cond
        [(and (eq? 'unix (system-type))

collects/mred/private/wx/gtk/gl-context.rkt

@@ -1,11 +1,132 @@
-#lang scheme/base
-(require scheme/class
-          "../../syntax.rkt")
+#lang racket/base
+(require racket/class
+         ffi/unsafe
+         ffi/unsafe/define
+         (prefix-in draw: racket/draw/gl-context)
+         racket/draw/gl-config
+         "types.rkt"
+         "utils.rkt")
 
-(provide gl-context%)
+(provide create-widget-gl-context)
 
-(defclass gl-context% object%
-  (def/public-unimplemented call-as-current)
-  (def/public-unimplemented swap-buffers)
-  (def/public-unimplemented ok?)
-  (super-new))
+(define gdkglext-lib
+  (ffi-lib "libgdkglext-x11-1.0" '("0")))
+(define gtkglext-lib
+  (ffi-lib "libgtkglext-x11-1.0" '("0")))
+
+(define-ffi-definer define-gdkglext gdkglext-lib
+  #:default-make-fail make-not-available)
+(define-ffi-definer define-gtkglext gtkglext-lib
+  #:default-make-fail make-not-available)
+
+(define _GdkGLContext (_cpointer/null 'GdkGLContext))
+(define _GdkGLDrawable (_cpointer 'GdkGLDrawable))
+(define _GdkGLConfig (_cpointer 'GdkGLConfig))
+
+(define-gdkglext gdk_gl_init (_fun (_ptr i _int)
+                                   (_ptr i _pointer)
+                                   -> _void)
+  #:fail void)
+
+(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig)))
+(define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig)))
+(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
+
+(define-gtkglext gtk_widget_set_gl_capability (_fun _GtkWidget
+                                                    _GdkGLConfig
+                                                    _GdkGLContext
+                                                    _gboolean
+                                                    _int
+                                                    -> _gboolean)
+  #:fail (lambda args #f))
+
+(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext))
+(define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable))
+
+(define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable
+                                                _GdkGLContext
+                                                -> _gboolean))
+(define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void))
+(define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void))
+
+(define GDK_GL_USE_GL                     1)
+(define GDK_GL_BUFFER_SIZE                2)
+(define GDK_GL_LEVEL                      3)
+(define GDK_GL_RGBA                       4)
+(define GDK_GL_DOUBLEBUFFER               5)
+(define GDK_GL_STEREO                     6)
+(define GDK_GL_AUX_BUFFERS                7)
+(define GDK_GL_RED_SIZE                   8)
+(define GDK_GL_GREEN_SIZE                 9)
+(define GDK_GL_BLUE_SIZE                  10)
+(define GDK_GL_ALPHA_SIZE                 11)
+(define GDK_GL_DEPTH_SIZE                 12)
+(define GDK_GL_STENCIL_SIZE               13)
+(define GDK_GL_ACCUM_RED_SIZE             14)
+(define GDK_GL_ACCUM_GREEN_SIZE           15)
+(define GDK_GL_ACCUM_BLUE_SIZE            16)
+(define GDK_GL_ACCUM_ALPHA_SIZE           17)
+(define GDK_GL_SAMPLE_BUFFERS             100000)
+(define GDK_GL_SAMPLES                    100001)
+(define GDK_GL_ATTRIB_LIST_NONE 0)
+
+;; ----------------------------------------
+
+(define (config->GdkGLConfig d conf)
+  (gdk_gl_config_new_for_screen d
+                                (list GDK_GL_USE_GL 1
+                                      GDK_GL_DOUBLEBUFFER (if (send conf get-double-buffered) 1 0)
+                                      GDK_GL_STEREO (if (send conf get-stereo) 1 0)
+                                      GDK_GL_DEPTH_SIZE (send conf get-depth-size)
+                                      GDK_GL_STENCIL_SIZE (send conf get-stencil-size)
+                                      GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size)
+                                      GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size)
+                                      GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size)
+                                      GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size)
+                                      GDK_GL_SAMPLES (send conf get-multisample-size)
+                                      GDK_GL_ATTRIB_LIST_NONE 0)))
+
+;; ----------------------------------------
+
+(define gl-context% 
+  (class draw:gl-context%
+    (init-field [gl gl]
+                [drawable drawable])
+
+    (define/override (draw:do-call-as-current t)
+      (dynamic-wind
+          (lambda ()
+            (gdk_gl_drawable_gl_begin gl drawable))
+          t
+          (lambda ()
+            (gdk_gl_drawable_gl_end drawable))))
+        
+    (define/override (draw:do-swap-buffers)
+      (gdk_gl_drawable_swap_buffers drawable))
+    
+    (super-new)))
+
+;; ----------------------------------------
+
+(define inited? #f)
+(define (init!)
+  (unless inited? 
+    (set! inited? #t)
+    (gdk_gl_init 0 #f)))
+
+(define (create-widget-gl-context gtk config)
+  (init!)
+  (let ([config (config->GdkGLConfig (gtk_widget_get_screen gtk)
+                                     (or config
+                                         (new gl-config%)))])
+    (and config
+         (gtk_widget_set_gl_capability gtk
+                                       config
+                                       #f
+                                       #t
+                                       #f)
+         (let ([gl (gtk_widget_get_gl_context gtk)])
+           (and gl
+              (new gl-context% 
+                   [gl gl]
+                   [drawable (gtk_widget_get_gl_window gtk)]))))))

collects/mred/private/wx/gtk/platform.rkt

@@ -9,7 +9,6 @@
          "dialog.rkt"
          "frame.rkt"
          "gauge.rkt"
-         "gl-context.rkt"
          "group-panel.rkt"
          "item.rkt"
          "list-box.rkt"
@@ -37,7 +36,6 @@
    dialog%
    frame%
    gauge%
-   gl-context%
    group-panel%
    item%
    list-box%

collects/mred/private/wx/gtk/procs.rkt

@@ -81,8 +81,6 @@
 (define-unimplemented write-resource)
 (define-unimplemented get-resource)
 
-(define _GdkScreen (_cpointer 'GdkScreen))
-(define-gdk gdk_screen_get_default (_fun -> _GdkScreen))
 (define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
 (define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))
 

collects/mred/private/wx/gtk/types.rkt

@@ -5,6 +5,7 @@
 (provide _GdkWindow
          _GtkWidget _GtkWindow
          _GdkDisplay
+         _GdkScreen
          _gpointer
          _GType
 
@@ -36,6 +37,7 @@
 (define _GtkWindow _GtkWidget)
 
 (define _GdkDisplay (_cpointer 'GdkDisplay))
+(define _GdkScreen (_cpointer 'GdkScreen))
 
 (define _gpointer _GtkWidget)
 

collects/mred/private/wx/gtk/utils.rkt

@@ -41,6 +41,8 @@
 
          define-signal-handler
 
+         gdk_screen_get_default
+
 	 ;; for declaring derived structures:
 	 _GtkObject)
 
@@ -203,3 +205,5 @@
                        (cons ((ctype-c->scheme elem) (g-slist-data gl))
                              (L (g-slist-next gl)))))
                  (g_slist_free gl)))))
+
+(define-gdk gdk_screen_get_default (_fun -> _GdkScreen))

collects/mred/private/wx/platform.rkt

@@ -21,7 +21,6 @@
                 dialog%
                 frame%
                 gauge%
-                gl-context%
                 group-panel%
                 item%
                 list-box%

collects/mred/private/wx/win32/platform.rkt

@@ -37,7 +37,6 @@
    dialog%
    frame%
    gauge%
-   gl-context%
    group-panel%
    item%
    list-box%

collects/racket/draw.rkt

@@ -11,7 +11,9 @@
          "draw/dc-intf.rkt"
          "draw/bitmap-dc.rkt"
          "draw/post-script-dc.rkt"
-         "draw/ps-setup.rkt")
+         "draw/ps-setup.rkt"
+         "draw/gl-config.rkt"
+         "draw/gl-context.rkt")
 
 (provide color%
          color-database<%> the-color-database
@@ -27,4 +29,6 @@
          bitmap-dc%
          post-script-dc%
          ps-setup% current-ps-setup
-         get-face-list)
+         get-face-list
+         gl-config%
+         gl-context<%>)

collects/racket/draw/dc.rkt

@@ -210,6 +210,9 @@
     (define/public (erase)
       (void))
 
+    (define/public (get-gl-context)
+      #f)
+
     (super-new)))
 
 (define hilite-color (send the-color-database find-color "black"))
@@ -1609,6 +1612,7 @@
                      (install-alternate-face c layout font desc attrs context)
                      (zero? (pango_layout_get_unknown_glyphs_count layout))))
             (g_object_unref layout))))))
-    
-    )
+
+    (void))
+
   dc%)

collects/racket/draw/gl-config.rkt

@@ -0,0 +1,36 @@
+#lang scheme/base
+(require scheme/class
+          "syntax.rkt")
+
+(provide gl-config%)
+
+(defclass gl-config% object%
+  (super-new)
+
+  (define double-buffered? #t)
+  (define/public (get-double-buffered) double-buffered?)
+  (define/public (set-double-buffered v) (set! double-buffered? (and v #t)))
+
+  (define stereo? #t)
+  (define/public (get-stereo) stereo?)
+  (define/public (set-stereo v) (set! stereo? (and v #t)))
+
+  (define stencil-size 0)
+  (define/public (get-stencil-size) stencil-size)
+  (def/public (set-stencil-size [(integer-in 0 256) s])
+    (set! stencil-size s))
+    
+  (define accum-size 0)
+  (define/public (get-accum-size) accum-size)
+  (def/public (set-accum-size [(integer-in 0 256) s])
+    (set! accum-size s))
+
+  (define depth-size 0)
+  (define/public (get-depth-size) depth-size)
+  (def/public (set-depth-size [(integer-in 0 256) s])
+    (set! depth-size s))
+
+  (define multisample-size 0)
+  (define/public (get-multisample-size) multisample-size)
+  (def/public (set-multisample-size [(integer-in 0 256) s])
+    (set! multisample-size s)))

collects/racket/draw/gl-context.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+(require racket/class
+         "syntax.rkt")
+
+(provide gl-context%
+         gl-context<%>
+         
+         do-call-as-current
+         do-swap-buffers)
+
+(define-local-member-name
+  do-call-as-current
+  do-swap-buffers)
+
+(define (procedure-arity-0? v) 
+  (and (procedure? v)
+       (procedure-arity-includes? v 0)))
+
+;; Implemented by subclasses:
+(defclass gl-context% object%
+  (define lock-thread #f)
+  (define lock (make-semaphore))
+  
+  (define/private (with-gl-lock t)
+    (if (eq? lock-thread (current-thread))
+        (t)
+        (call-with-semaphore
+         lock
+         (lambda ()
+           (set! lock-thread (current-thread))
+           (begin0 
+            (t)
+            (set! lock-thread #f))))))
+
+  (def/public (call-as-current [procedure-arity-0? t])
+    (with-gl-lock
+     (lambda ()
+       (do-call-as-current t))))
+        
+  (define/public (swap-buffers)
+    (with-gl-lock
+     (lambda ()
+       (do-swap-buffers))))
+
+  (define/public (ok?) #t)
+
+  (define/public (do-call-as-current t) (t))
+  (define/public (do-swap-buffers t) (void))
+
+  (super-new))
+
+(define gl-context<%> (class->interface gl-context%))