読者です 読者をやめる 読者になる 読者になる

Perl OpenGL, Gtk2::GLExt のサンプルプログラム

perl OpenGL GTK

フォントの使い方の例。 'q' で終了。

#! /usr/bin/perl

## A sample program for perl-Gtk2-GLExt and its Font Usage.
## written by ryo1miya (http://d.hatena.ne.jp/ryo1miya) .

##
## font class
##
package Font;

use strict;

use Gtk2::GLExt;
use OpenGL qw/:all/;

# constructor
sub new {
    my $class = shift;
    my $self = {
	name => shift, # font name
        base => undef  # list base for OpenGL DisplayList
    };

    # Generate OpenGL DisplayList
    $self->{base} = glGenLists(128);
    my $font_desc = Gtk2::Pango::FontDescription->from_string($self->{name});
    my $font = Gtk2::Gdk::GLExt::Font->use_pango_font($font_desc, 0, 127, $self->{base});

    die "*** Cannot load font.\n" if (!$font);

    return bless $self, $class;
}

# destructor
sub DESTROY {
    my $self = shift;
    glDeleteLists($self->base, 128);
}

# accessor(getter)
sub name {
    my $self = shift;
    $self->{name};
}

sub base {
    my $self = shift;
    $self->{base};
}

# method
sub print {
    my ($self, $str) = @_;

    glListBase($self->base);
    glCallLists_s (length($str), GL_UNSIGNED_BYTE, $str);
}

##
## main class
##
package main;

use strict;
use Gtk2 '-init';
use Gtk2::Gdk::Keysyms;
use Gtk2::GLExt;

use OpenGL qw/:all/;

# colors
my @white = (1.0, 1.0, 1.0, 1.0);
my @red = (0.8, 0.0, 0.0, 1.0);
my @blue = (0.0, 0.0, 0.8, 1.0);

# font objects
my ($hlv20, $hlv36, $mono14);

sub realize {
    my ($widget, $data) = @_;
    
    my $glcontext = $widget->get_gl_context;
    my $gldrawable = $widget->get_gl_drawable;

    return unless $gldrawable->gl_begin($glcontext);

    # Prepare fonts
    $hlv20 = new Font("Helvetica Bold 20");
    $hlv36 = new Font("Helvetica 36");
    $mono14 = new Font("Bitstream Vera Sans Mono 14");
   
    glClearColor (0.0, 0.0, 0.0, 1.0);
    
    $gldrawable->gl_end();

    return 1;
}

sub configure_event {
    my ($widget, $event, $data) = @_;
    
    my $glcontext = $widget->get_gl_context;
    my $gldrawable = $widget->get_gl_drawable;
    
    return 0 unless $gldrawable->gl_begin ($glcontext);
    
    my $w = $widget->allocation->width;
    my $h = $widget->allocation->height;
    
    glViewport (0, 0, $w, $h);
    
    glMatrixMode (GL_PROJECTION);
    glLoadIdentity ();

    gluOrtho2D(0, $w, 0, $h);
    
    $gldrawable->gl_end;
    
    return 1;
}

sub expose_event {
    my ($widget, $event, $data) = @_;
    
    my $glcontext = $widget->get_gl_context;
    my $gldrawable = $widget->get_gl_drawable;
    
    return 0 unless $gldrawable->gl_begin ($glcontext);
    
    glClear (GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT);

    # print string
    glMatrixMode (GL_MODELVIEW);
    glLoadIdentity;
    
    glColor4fv_p(@white);
    glRasterPos2i(70, 70);
    $hlv20->print("Bold Font : press 'q' to quit!");

    glColor4fv_p(@red);
    glRasterPos2i(200, 180);
    $hlv36->print("Helvetica 36");

    glColor4fv_p(@blue);
    glRasterPos2i(100, 300);
    $mono14->print($_) for ('a'..'z');
    glRasterPos2i(100, 320);
    $mono14->print($_) for ('A'..'Z');
    
    if ($gldrawable->is_double_buffered) {
	$gldrawable->swap_buffers;
    } else {
	glFlush;
    }

    $gldrawable->gl_end;
    
    return 1;
}

sub create_gl_drawing_area {
    my ($glconfig) = @_;

    my $vbox;
    my $drawing_area;

    # VBox.

    $vbox = Gtk2::VBox->new (0, 0);
    $vbox->set_border_width (0);

    # Drawing area for drawing OpenGL scene.
    $drawing_area = Gtk2::DrawingArea->new;
    $drawing_area->set_size_request (500, 500);

    # Set OpenGL-capability to the widget.
    $drawing_area->set_gl_capability ($glconfig, undef, 1, 'rgba_type');

    # Connect OpenGL CallBack
    $drawing_area->signal_connect_after (realize => \&realize);
    $drawing_area->signal_connect (configure_event => \&configure_event);
    $drawing_area->signal_connect (expose_event => \&expose_event);

    $vbox->pack_start ($drawing_area, 1, 1, 0);
    $drawing_area->show;

    # Show VBox.
    $vbox->show;

    return $vbox;
}

sub main {

    my $glconfig;
    my $window;
    my $vbox;

    ## Init GtkGLExt.
    Gtk2::GLExt->init;

    ## Configure OpenGL-capable visual.
    # Try double-buffered visual
    $glconfig = Gtk2::Gdk::GLExt::Config->new_by_mode ([qw/rgb depth double/]);
    unless ($glconfig)
    {
	print STDERR ("*** Cannot find the double-buffered visual.\n");
	print STDERR ("*** Trying single-buffered visual.\n");

	# Try single-buffered visual
	$glconfig = Gtk2::Gdk::GLExt::Config->new_by_mode ([qw/rgb depth/]);
	unless ($glconfig)
        {
	    print STDERR ("*** No appropriate OpenGL-capable visual found.\n");
	    exit (1);
        }
    }

    ## Top-level window.

    $window = Gtk2::Window->new ('toplevel');
    $window->set_title ('FontTest');

    # Perform the resizes immediately on WIN32
    $window->set_resize_mode ('immediate') if( $^O eq 'MSWin32' );
    # Get automatically redrawn if any of their children changed allocation.
    $window->set_reallocate_redraws (1);
    # Set border width.
    $window->set_border_width (0);

    ## Signal

    # delete
    $window->signal_connect (delete_event => sub {Gtk2->main_quit; 1});

    # press 'q' to quit.
    $window->add_events('key-press-mask');
    $window->signal_connect (key_press_event => 
			     sub {
				 my ($widget, $event) = @_;
				 if ($event->keyval == $Gtk2::Gdk::Keysyms{q}) {
				     Gtk2->main_quit;
				 }
			     });

    ## add drawing area
    $vbox = create_gl_drawing_area ($glconfig);
    $window->add ($vbox);

    ## Show window.
    $window->show;

    ## Main loop.
    Gtk2->main;

    return 0;
}

&main;