# Copyright 2010, 2011, 2012 Kevin Ryde
# This file is part of Image-Base-Gtk2.
#
# Image-Base-Gtk2 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 3, or (at your option) any later
# version.
#
# Image-Base-Gtk2 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 Image-Base-Gtk2. If not, see <http://www.gnu.org/licenses/>.
package Image::Base::Gtk2::Gdk::Drawable;
use 5.008;
use strict;
use warnings;
use Carp;
use Image::Base;
our @ISA = ('Image::Base');
# uncomment this to run the ### lines
#use Smart::Comments;
our $VERSION = 11;
sub new {
my ($class, %params) = @_;
my $self = bless { _gc_colour => '',
_gc_colour_pixel => -1,
}, $class;
### Image-Base-Gtk2-Gdk-Drawable new: $self
$self->set (%params);
return $self;
}
my %attr_to_get_method = (-colormap => 'get_colormap',
-depth => 'get_depth',
-screen => 'get_screen',
# no get_width method or property, just
# get_size()
-width => sub { ($_[0]->get_size)[0] },
-height => sub { ($_[0]->get_size)[1] },
);
sub _get {
my ($self, $key) = @_;
if (my $method = $attr_to_get_method{$key}) {
return $self->{'-drawable'}->$method;
}
if ($key eq '-pixmap' || $key eq '-window') { # aliasing
$key = '-drawable';
}
return $self->SUPER::_get($key);
}
sub set {
my ($self, %params) = @_;
### Image-Base-Gtk2-Gdk-Drawable set: \%params
foreach my $key ('-depth', '-screen') {
if (exists $params{$key}) {
croak "Attribute $key is read-only";
}
}
if (exists $params{'-gc'}) {
# when setting -gc no longer assume the current foreground pixel
$params{'_gc_colour'} = '';
$params{'_gc_pixel'} = -1;
}
# aliasing
if (exists $params{'-pixmap'}) {
$params{'-drawable'} = delete $params{'-pixmap'};
}
if (exists $params{'-window'}) {
$params{'-drawable'} = delete $params{'-window'};
}
# set -drawable now so as to apply -colormap and size to possible new one
if (exists $params{'-drawable'}) {
$self->{'-drawable'} = delete $params{'-drawable'};
}
if (exists $params{'-colormap'}) {
$self->{'-drawable'}->set_colormap (delete $params{'-colormap'});
}
my $width = delete $params{'-width'};
my $height = delete $params{'-height'};
if (defined $width || defined $height) {
if (! defined $width) { $width = ($self->{'-drawable'}->get_size)[0]; }
if (! defined $height) { $height = ($self->{'-drawable'}->get_size)[1]; }
$self->{'-drawable'}->resize ($width, $height);
}
%$self = (%$self, %params);
### set leaves: $self
}
#------------------------------------------------------------------------------
# drawing
sub xy {
my ($self, $x, $y, $colour) = @_;
if (@_ >= 4) {
### Image-Gtk2GdkDrawable xy: "$x, $y, $colour"
$self->{'-drawable'}->draw_point ($self->gc_for_colour($colour), $x, $y);
} else {
# fetch using Pixbuf as it looks up colours
if ($x < 0 || $y < 0) {
### get_from_drawable() won't read negative points ...
return undef; # fetch or store
}
my $drawable = $self->{'-drawable'};
my ($width, $height) = $drawable->get_size;
if ($x >= $width || $y >= $height) {
### get_from_drawable() won't read outside drawable size ...
return undef;
}
# $drawable->get_image would be an alternative, giving the full 16-bit
# GdkColor components, but Gtk2::Gdk::Image data not accessible as of
# Perl-Gtk 1.221
my $pixbuf = Gtk2::Gdk::Pixbuf->new ('rgb',
0, # has alpha
8, # bits per sample
1,1);
$pixbuf->get_from_drawable ($self->{'-drawable'}, undef, $x,$y, 0,0, 1,1);
### pixbuf get_pixels: length($pixbuf->get_pixels), $pixbuf->get_pixels
my @rgb = unpack('CCC', $pixbuf->get_pixels);
### @rgb
if ($drawable->isa('Gtk2::Gdk::Pixmap')
&& $drawable->get_depth == 1
&& ! $drawable->get_colormap) {
return ($rgb[0]||$rgb[1]||$rgb[2] ? 1 : 0);
} else {
return sprintf '#%02X%02X%02X', @rgb
}
}
}
# Crib note: no limit on how many points passed to draw_points(). The
# underlying xlib XDrawPoints() automatically splits into multiple PolyPoint
# requests as necessary.
#
sub Image_Base_Other_xy_points {
my $self = shift;
my $colour = shift;
### Image_Base_Other_xy_points $colour
### len: scalar(@_)
@_ or return;
### drawable: $self->{'-drawable'}
### gc: $self->gc_for_colour($colour)
unshift @_, $self->{'-drawable'}, $self->gc_for_colour($colour);
### len: scalar(@_)
### $_[0]
### $_[1]
# shift/unshift changes the first two args from self,colour to drawable,gc
# does that save stack copying?
my $code = $self->{'-drawable'}->can('draw_points');
goto &$code;
# the plain equivalent ...
# $self->{'-drawable'}->draw_points ($self->gc_for_colour($colour), @_);
}
sub line {
my ($self, $x1,$y1, $x2,$y2, $colour) = @_;
### Image-Gtk2GdkDrawable line()
$self->{'-drawable'}->draw_line ($self->gc_for_colour($colour),
$x1,$y1, $x2,$y2);
}
# $x1==$x2 and $y1==$y2 on $fill==false may or may not draw that x,y point
# outline with gc line_width==0
# or alternately $drawable->draw_point ($gc, $x1,$y1);
#
sub rectangle {
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
# ### Image-Gtk2GdkDrawable rectangle: "$x1, $y1, $x2, $y2, $colour, $fill"
$fill = !! $fill;
$fill ||= ($x1 == $x2 || $y1 == $y2);
$self->{'-drawable'}->draw_rectangle ($self->gc_for_colour($colour), $fill,
$x1, $y1,
$x2-$x1+$fill, $y2-$y1+$fill);
# or with WidgetBits,
# Gtk2::Ex::GdkBits::draw_rectangle_corners
# ($self->{'-drawable'}
# $self->gc_for_colour($colour),
# $fill, $x1,$y1, $x2,$y2);
}
# Per notes in Image::Base::X11::Protocol::Drawable, a filled arc ellipse is
# effectively 0.5 pixel smaller. To make sure rightmost and bottom pixels
# are drawn for now try an unfilled on top of a filled to get that extra 0.5
# around the outside. Can it be done better?
#
sub ellipse {
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
### Image-Gtk2GdkDrawable ellipse: "$x1, $y1, $x2, $y2, $colour, ".($fill?1:0)
my $drawable = $self->{'-drawable'};
my $gc = $self->gc_for_colour($colour);
my $w = $x2 - $x1;
my $h = $y2 - $y1;
if ($w <= 1 || $h <= 1) {
# 1 or 2 pixels high or wide
$self->{'-drawable'}->draw_rectangle ($gc, 1, # filled
$x1, $y1, $w+1, $h+1);
} else {
foreach my $fillarg (0 .. !!$fill) {
$drawable->draw_arc ($gc, $fillarg,
$x1, $y1, $w, $h,
0, 360*64); # angles in 64ths of a 360 degrees
}
}
}
sub diamond {
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
### Image-Gtk2GdkDrawable diamond: "$x1, $y1, $x2, $y2, $colour, ".($fill?1:0)
my $drawable = $self->{'-drawable'};
my $gc = $self->gc_for_colour($colour);
if ($x1==$x2 && $y1==$y2) {
# 1x1 polygon draws nothing, do it as a point instead
$drawable->draw_point ($gc, $x1,$y1);
} else {
my $xh = ($x2 - $x1);
my $yh = ($y2 - $y1);
my $xeven = ($xh & 1);
my $yeven = ($yh & 1);
$xh = int($xh / 2);
$yh = int($yh / 2);
### assert: $x1+$xh+$xeven == $x2-$xh
### assert: $y1+$yh+$yeven == $y2-$yh
my @points = ($x1+$xh, $y1, # top centre
# left
$x1, $y1+$yh,
($yeven ? ($x1, $y2-$yh) : ()),
# bottom
$x1+$xh, $y2,
($xeven ? ($x2-$xh, $y2) : ()),
# right
($yeven ? ($x2, $y2-$yh) : ()),
$x2, $y1+$yh,
($xeven ? ($x2-$xh, $y1) : ()),
$x1+$xh, $y1); # back to start
foreach my $fillarg (0 .. !!$fill) {
$drawable->draw_polygon ($gc,
$fillarg,
@points);
}
}
}
# return '-gc' with its foreground set to $colour
# -gc is created if not already set
# the colour set is recorded to save work if the next drawing is the same
#
sub gc_for_colour {
my ($self, $colour) = @_;
my $gc = $self->{'-gc'};
if ($colour ne $self->{'_gc_colour'}) {
### gc_for_colour change: $colour
my $colorobj = $self->colour_to_colorobj($colour);
### pixel: sprintf("%#X",$colorobj->pixel)
$self->{'_gc_colour'} = $colour;
if ($colorobj->pixel ne $self->{'_gc_colour_pixel'}) {
$self->{'_gc_colour_pixel'} = $colorobj->pixel;
if (! $gc) {
return ($self->{'-gc'}
= Gtk2::Gdk::GC->new ($self->{'-drawable'},
{ foreground => $colorobj }));
}
$gc->set_foreground ($colorobj);
}
}
return $gc;
}
sub colour_to_colorobj {
my ($self, $colour) = @_;
if ($colour =~ /^\d+$/) {
return Gtk2::Gdk::Color->new (0,0,0, $colour);
}
if ($colour eq 'set') {
return Gtk2::Gdk::Color->new (0,0,0, 1);
}
if ($colour eq 'clear') {
return Gtk2::Gdk::Color->new (0,0,0, 0);
}
my $drawable = $self->{'-drawable'};
my $colormap = $drawable->get_colormap;
if (! $colormap) {
if ($drawable->get_depth == 1) {
if ($colour =~ /^#(000)+$/) {
return Gtk2::Gdk::Color->new (0,0,0, 0);
} elsif ($colour =~ /^#(FFF)+$/i) {
return Gtk2::Gdk::Color->new (0,0,0, 1);
}
}
croak "No colormap to interpret colour: $colour";
}
# think parse and rgb_find are client-side operations, no need to cache
# the results
#
my $colorobj = Gtk2::Gdk::Color->parse ($colour)
|| croak "Cannot parse colour: $colour";
$colormap->rgb_find_color ($colorobj);
return $colorobj;
}
1;
__END__
=for stopwords resized filename Ryde Gdk bitmap pixmap pixmaps colormap colormaps Image-Base-Gtk2 Pango Gtk
=head1 NAME
Image::Base::Gtk2::Gdk::Drawable -- draw into a Gdk window or pixmap
=for test_synopsis my $win_or_pixmap
=head1 SYNOPSIS
use Image::Base::Gtk2::Gdk::Drawable;
my $image = Image::Base::Gtk2::Gdk::Drawable->new
(-drawable => $win_or_pixmap);
$image->line (0,0, 99,99, '#FF00FF');
$image->rectangle (10,10, 20,15, 'white');
=head1 CLASS HIERARCHY
C<Image::Base::Gtk2::Gdk::Drawable> is a subclass of
C<Image::Base>,
Image::Base
Image::Base::Gtk2::Gdk::Drawable
=head1 DESCRIPTION
C<Image::Base::Gtk2::Gdk::Drawable> extends C<Image::Base> to draw into a
Gdk drawable, meaning either a window or a pixmap.
Colour names are anything recognised by C<< Gtk2::Gdk::Color->parse >>,
which means various names like "pink" plus hex #RRGGBB or #RRRRGGGGBBB. As
of Gtk 2.20 the colour names are the Pango compiled-in copy of the X11
F<rgb.txt>. Special names "set" and "clear" mean pixel values 1 and 0 for
use with bitmaps.
The C<Image::Base::Gtk2::Gdk::Pixmap> subclass has some specifics for
creating pixmaps, but this base Drawable is enough to draw into an existing
one.
Native Gdk drawing does much more than C<Image::Base> but if you have some
generic pixel twiddling code for C<Image::Base> then this Drawable class
lets you point it at a Gdk window etc. Drawing into a window is a good way
to show slow drawing progressively, rather than drawing into a pixmap or
image file and only displaying when complete. See C<Image::Base::Multiplex>
for a way to do both simultaneously.
=head1 FUNCTIONS
See L<Image::Base/FUNCTIONS> for the behaviour common to all Image-Base
classes.
=over 4
=item C<$image = Image::Base::Gtk2::Gdk::Drawable-E<gt>new (key=E<gt>value,...)>
Create and return a new image object. A C<-drawable> parameter must be
given,
$image = Image::Base::Gtk2::Gdk::Drawable->new
(-drawable => $win_or_pixmap);
Further parameters are applied per C<set> (see L</ATTRIBUTES> below).
=item C<$image-E<gt>xy ($x, $y, $colour)>
Get or set the pixel at C<$x>,C<$y>.
In the current code colours are returned in #RRGGBB form and require a
colormap. Perhaps in the future it will be #RRRRGGGGBBBB form since under X
there's 16-bit resolution. Generally a colormap is required, though bitmaps
without a colormap give 0 and 1. The intention is probably to have pixmaps
without colormaps give back raw pixel values. Maybe bitmaps could give back
"set" and "clear" as an option.
Fetching a pixel is an X server round-trip and reading out a big region will
be slow. The server can give a region or the entire drawable in one go, so
some function for that would be better if much fetching is needed.
=back
=head1 ATTRIBUTES
=over
=item C<-drawable> (C<Gtk2::Gdk::Drawable> object)
The target drawable.
=item C<-width> (integer)
=item C<-height> (integer)
The size of the drawable per C<< $drawable->get_size >>.
=item C<-colormap> (C<Gtk2::Gdk::Colormap>, or C<undef>)
The colormap in the underlying C<-drawable> per
C<< $drawable->get_colormap >>. Windows always have a colormap, but pixmaps
may or may not.
=item C<-depth> (integer, read-only)
The number of bits per pixel in the drawable, from
C<< $drawable->get_depth >>.
=item C<-screen> (C<Gtk2::Gdk::Screen>, read-only)
The screen of the underlying drawable (C<< $drawable->get_screen >>).
=back
=head1 SEE ALSO
L<Image::Base>,
L<Image::Base::Gtk2::Gdk::Pixmap>,
L<Image::Base::Gtk2::Gdk::Window>,
L<Gtk2::Gdk::Drawable>,
L<Image::Base::Multiplex>
=head1 HOME PAGE
L<http://user42.tuxfamily.org/image-base-gtk2/index.html>
=head1 LICENSE
Copyright 2010, 2011, 2012 Kevin Ryde
Image-Base-Gtk2 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 3, or (at your option) any later
version.
Image-Base-Gtk2 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
Image-Base-Gtk2. If not, see L<http://www.gnu.org/licenses/>.
=cut