Feature Request: Add support for GLArea

examples/dune

@@ -29,6 +29,7 @@
    ; testdnd testgtk
    testthread ; timer toolbar
    tooltip tree tree_model tree_store ; tron
+   glarea
  )
  (modules
    about accel_tree action assistant assistant_tutorial
@@ -46,6 +47,7 @@
    stackcontainer stackswitcher
    testdnd ; testgtk
    testthread timer toolbar tooltip tree tree_model tree_store tron
+   glarea
  )
  (flags :standard -w -3-6-7-10-24-26-27-33-35 -no-strict-sequence)
  (libraries lablgtk3))

examples/glarea.ml

@@ -0,0 +1,12 @@
+
+let () =
+  ignore @@ GMain.init ();
+  let window = GWindow.window () in
+  ignore @@ window#connect#destroy ~callback:GMain.quit;
+  let obj = GlGtk.area ~packing:window#add () in
+  obj#set_required_version 3 2;
+  obj#set_has_auto_render true;
+  ignore @@ obj#connect#realize ~callback:(fun () -> print_endline "creating opengl context");
+  ignore @@ obj#connect#render ~callback:(fun () -> print_endline "rendering opengl context"; true);
+  window#show ();
+  GtkMain.Main.main ()

src/dune

@@ -33,6 +33,7 @@
    ml_gtkaction ml_gtkbin ml_gtkbutton ml_gtktext ml_gtkedit
    ml_gtkmenu ml_gtkfile ml_gtktree ml_gtkpack
    ml_gtkstock ml_gtkrange ml_gtkassistant
+   ml_gtkgl
  )
  (c_flags         (:include cflag-gtk+-3.0.sexp) (:include cflag-extraflags.sexp) -Wno-deprecated-declarations)
  (c_library_flags (:include clink-gtk+-3.0.sexp))

src/glGtk.ml

@@ -0,0 +1,119 @@
+(**************************************************************************)
+(*                Lablgtk                                                 *)
+(*                                                                        *)
+(*    This program is free software; you can redistribute it              *)
+(*    and/or modify it under the terms of the GNU Library General         *)
+(*    Public License as published by the Free Software Foundation         *)
+(*    version 2, with the exception described in file COPYING which       *)
+(*    comes with the library.                                             *)
+(*                                                                        *)
+(*    This program 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 Library General Public License for more details.                *)
+(*                                                                        *)
+(*    You should have received a copy of the GNU Library General          *)
+(*    Public License along with this program; if not, write to the        *)
+(*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         *)
+(*    Boston, MA 02111-1307  USA                                          *)
+(*                                                                        *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+open Gaux
+open Gtk
+
+type gl_area = [Gtk.drawing_area|`glarea]
+
+module GtkRaw = struct
+  external create : unit -> gl_area obj = "ml_gtk_gl_area_new"
+
+  external make_current : [>`glarea] obj -> unit = "ml_gtk_gl_area_make_current"
+
+  external set_has_alpha : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_alpha"
+  external get_has_alpha : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_alpha"
+
+  external set_has_depth_buffer : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_depth_buffer"
+  external get_has_depth_buffer : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_depth_buffer"
+
+  external set_has_stencil_buffer : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_stencil_buffer"
+  external get_has_stencil_buffer : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_stencil_buffer"
+
+  external set_has_auto_render : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_auto_render"
+  external get_has_auto_render : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_auto_render"
+
+  external set_required_version : [>`glarea] obj -> int -> int -> unit = "ml_gtk_gl_area_set_required_version"
+  external get_required_version : [>`glarea] obj -> (int * int) = "ml_gtk_gl_area_get_required_version"
+
+end
+
+class area_signals obj =
+object (connect)
+  inherit GObj.widget_signals_impl (obj : [> gl_area] obj)
+  method display ~callback =
+    (new GObj.event_signals obj)#after#expose ~callback:
+      begin fun ev ->
+	if GdkEvent.Expose.count ev = 0 then begin
+            GtkRaw.make_current obj;
+            callback ()
+        end;
+	true
+      end
+
+
+  method render ~callback =
+    let render =
+      GtkSignal.{name="render"; classe=`widget; marshaller=fun f ->
+        marshal1_ret ~ret:Gobject.Data.boolean
+          (Gobject.Data.gobject_option : _ Gobject.data_conv)
+          "Gtk::render" f} in
+    let f = connect#connect render in
+    f (fun _ -> callback ())
+
+  method reshape ~(callback: (width:int -> height:int -> unit)) =
+    (new GObj.event_signals obj)#after#configure ~callback:
+      begin fun ev ->
+        GtkRaw.make_current obj;
+	callback ~width:(GdkEvent.Configure.width ev) ~height:(GdkEvent.Configure.height ev);
+	true
+      end
+  method realize ~callback =
+    (new GObj.misc_signals (obj :> Gtk.widget obj))#after#realize ~callback:
+      begin fun ev ->
+        GtkRaw.make_current obj;
+        callback ()
+      end
+end
+
+class area obj = object (self)
+  inherit GObj.widget (obj : gl_area obj)
+  method as_area = obj
+  method event = new GObj.event_ops obj
+  method connect = new area_signals obj
+  (* method set_size = GtkMisc.DrawingArea.size obj *)
+  method make_current () = ignore (GtkRaw.make_current obj) 
+
+  method set_has_alpha = GtkRaw.set_has_alpha obj
+  method get_has_alpha () = GtkRaw.get_has_alpha obj
+
+  method set_has_depth_buffer = GtkRaw.set_has_depth_buffer obj
+  method get_has_depth_buffer () = GtkRaw.get_has_depth_buffer obj
+
+  method set_has_stencil_buffer = GtkRaw.set_has_stencil_buffer obj
+  method get_has_stencil_buffer () = GtkRaw.get_has_stencil_buffer obj
+
+  method set_has_auto_render = GtkRaw.set_has_auto_render obj
+  method get_has_auto_render () = GtkRaw.get_has_auto_render obj
+
+  method set_required_version = GtkRaw.set_required_version obj
+  method get_required_version () = GtkRaw.get_required_version obj
+
+end
+
+let area ?packing ?show () =
+  let w = GtkRaw.create () in
+  GtkBase.Widget.add_events w [`EXPOSURE];
+  GObj.pack_return (new area w) ~packing ~show
+

src/glGtk.mli

@@ -0,0 +1,92 @@
+(**************************************************************************)
+(*                Lablgtk                                                 *)
+(*                                                                        *)
+(*    This program is free software; you can redistribute it              *)
+(*    and/or modify it under the terms of the GNU Library General         *)
+(*    Public License as published by the Free Software Foundation         *)
+(*    version 2, with the exception described in file COPYING which       *)
+(*    comes with the library.                                             *)
+(*                                                                        *)
+(*    This program 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 Library General Public License for more details.                *)
+(*                                                                        *)
+(*    You should have received a copy of the GNU Library General          *)
+(*    Public License along with this program; if not, write to the        *)
+(*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         *)
+(*    Boston, MA 02111-1307  USA                                          *)
+(*                                                                        *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+open Gtk
+open GObj
+
+type gl_area = [Gtk.drawing_area|`glarea]
+
+module GtkRaw :
+  sig
+    external create : unit -> gl_area obj = "ml_gtk_gl_area_new"
+    external make_current : [>`glarea] obj -> unit = "ml_gtk_gl_area_make_current"
+
+    external set_has_alpha : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_alpha"
+    external get_has_alpha : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_alpha"
+
+    external set_has_depth_buffer : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_depth_buffer"
+    external get_has_depth_buffer : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_depth_buffer"
+
+    external set_has_stencil_buffer : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_has_stencil_buffer"
+    external get_has_stencil_buffer : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_has_stencil_buffer"
+
+    external set_has_auto_render : [>`glarea] obj -> bool -> unit = "ml_gtk_gl_area_set_auto_render"
+    external get_has_auto_render : [>`glarea] obj -> bool = "ml_gtk_gl_area_get_auto_render"
+
+    external set_required_version : [>`glarea] obj -> int -> int -> unit = "ml_gtk_gl_area_set_required_version"
+    external get_required_version : [>`glarea] obj -> (int * int) = "ml_gtk_gl_area_get_required_version"
+
+  end
+
+class area_signals : 'a obj ->
+  object
+    inherit GObj.widget_signals
+    constraint 'a = [> gl_area]
+    val obj : 'a obj
+    method display : callback:(unit -> unit) -> GtkSignal.id
+    method realize : callback:(unit -> unit) -> GtkSignal.id
+    method render: callback:(unit -> bool) -> GtkSignal.id
+    method reshape :
+      callback:(width:int -> height:int -> unit) -> GtkSignal.id
+  end
+
+class area : gl_area obj ->
+  object
+    inherit GObj.widget
+    val obj : gl_area obj
+    method event : event_ops
+    method as_area : gl_area obj
+    method connect : area_signals
+
+    method make_current : unit -> unit
+
+    method set_has_alpha : bool -> unit
+    method get_has_alpha : unit -> bool
+
+    method set_has_depth_buffer : bool -> unit
+    method get_has_depth_buffer : unit -> bool
+
+    method set_has_stencil_buffer : bool -> unit
+    method get_has_stencil_buffer : unit -> bool
+
+    method set_has_auto_render : bool -> unit
+    method get_has_auto_render : unit -> bool
+
+    method set_required_version : int -> int -> unit
+    method get_required_version : unit -> (int * int)
+
+  end
+
+val area : ?packing:(widget -> unit) -> ?show:bool -> unit -> area
+

src/gobject.ml

@@ -285,7 +285,8 @@ module Data = struct
   let gobject_option =
     { kind = `OBJECT;
       proj = (function `OBJECT c -> may_map ~f:unsafe_cast c
-             | _ -> failwith "Gobject.get_object");
+                     | `NONE -> None
+                     | _ -> failwith "Gobject.get_object");
       inj = (fun c -> `OBJECT (may_map ~f:unsafe_cast c)) }
   let gobject =
     { kind = `OBJECT;

src/ml_gtkgl.c

@@ -0,0 +1,68 @@
+/**************************************************************************/
+/*                Lablgtk                                                 */
+/*                                                                        */
+/*    This program is free software; you can redistribute it              */
+/*    and/or modify it under the terms of the GNU Library General         */
+/*    Public License as published by the Free Software Foundation         */
+/*    version 2, with the exception described in file COPYING which       */
+/*    comes with the library.                                             */
+/*                                                                        */
+/*    This program 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 Library General Public License for more details.                */
+/*                                                                        */
+/*    You should have received a copy of the GNU Library General          */
+/*    Public License along with this program; if not, write to the        */
+/*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         */
+/*    Boston, MA 02111-1307  USA                                          */
+/*                                                                        */
+/*                                                                        */
+/**************************************************************************/
+
+/* $Id$ */
+
+#include <gtk/gtk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_glib.h"
+#include "ml_gobject.h"
+#include "ml_gdk.h"
+#include "ml_gtk.h"
+/* #include "gtkgl_tags.h" */
+
+/* Conversion functions */
+/* #include "gtkgl_tags.c" */
+
+#define GtkGLArea_val(val) check_cast(GTK_GL_AREA,val)
+
+ML_0 (gtk_gl_area_new, Val_GtkWidget_sink)
+ML_1 (gtk_gl_area_make_current, GtkGLArea_val, Unit)
+
+ML_2 (gtk_gl_area_set_has_alpha, GtkGLArea_val, Bool_val, Unit)
+ML_1 (gtk_gl_area_get_has_alpha, GtkGLArea_val, Bool_val)
+
+ML_2 (gtk_gl_area_set_has_depth_buffer, GtkGLArea_val, Bool_val, Unit)
+ML_1 (gtk_gl_area_get_has_depth_buffer, GtkGLArea_val, Bool_val)
+
+ML_2 (gtk_gl_area_set_has_stencil_buffer, GtkGLArea_val, Bool_val, Unit)
+ML_1 (gtk_gl_area_get_has_stencil_buffer, GtkGLArea_val, Bool_val)
+
+ML_2 (gtk_gl_area_set_auto_render, GtkGLArea_val, Bool_val, Unit)
+ML_1 (gtk_gl_area_get_auto_render, GtkGLArea_val, Bool_val)
+
+ML_3 (gtk_gl_area_set_required_version, GtkGLArea_val, Int_val, Int_val, Unit)  
+CAMLprim value ml_gtk_gl_area_get_required_version(value area)
+{
+  int major, minor;
+  value res = alloc_tuple(2);
+  gtk_gl_area_get_required_version(GtkGLArea_val(area), &major, &minor);
+  Field(res,0) = Val_int(major);
+  Field(res,1) = Val_int(minor);
+  return res;
+}