Bug #17975 for SDL_perl: Speed up SDL::Color

Moin, you need a SDL::Color object to draw pixels via SDL::App::pixel(). When the pixels have different colors, you either need to construct a new object (and DESTROY it) for each pixel, or re-use a SDL::Color object by changing RGB by calling r(), g() and b(). Both methods are much slower than they ought to be. F.i. in my example mandelbrot app, which draws a few thousand pixels with hundred different colors a great part of the time is spent in SDL::Color->new(), DESTROY() and/or r(), g() and b(). The attached patch fixes that in two ways: * add the possibility to call SDL::Color->new($r,$g,$b); This saves the construction of a new non hash and maks a new()/DESTROY pair about 6.6 times faster. * add a rgb() method, this makes quering or setting new rgb values about 2.3 times faster. * add doc, fix a few POD niggles and add tests for the new stuff. An benchmark script (plus output filter) is also attached. # perl -Iblib -Iblib/arch bench.pl | perl filter.pl Benchmark: running new(-r -g -b), new(rgb), r(),g(),b(), r(1),g(2),b(3), rgb(), rgb(1,2,3) for at least 5 CPU seconds... new(-r -g -b) : 5s ( 5.30 usr + 0.02 sys = 5.32 CPU) @ 29147/s (n=155066) new(rgb) : 6s ( 5.27 usr + 0.06 sys = 5.33 CPU) @ 196122/s (n=1045333) r(),g(),b() : 5s ( 5.09 usr + 0.02 sys = 5.11 CPU) @ 229539/s (n=1172945) rgb() : 4s ( 5.00 usr + 0.02 sys = 5.02 CPU) @ 542725/s (n=2724482) r(1),g(2),b(3) : 5s ( 5.22 usr + -0.00 sys = 5.22 CPU) @ 272043/s (n=1420065) rgb(1,2,3) : 6s ( 5.27 usr + -0.00 sys = 5.27 CPU) @ 646711/s (n=3408171) Best wishes, Tels

#!/usr/bin/perl -w $|++; while (<>) { # find the first : and move it: $_ =~ s/^([^:]*): / pad($1,15) . ':' /eg unless $_ =~ /^Benchmark/; $_ =~ s/ wallclock secs/s/; $_ =~ s/@ (\d+)\.\d+/'@ ' . pad_left($1,7)/e; print $_; } sub pad { my ($t,$c) = @_; $t .= ' ' while length($t) < $c; $t; } sub pad_left { my ($t,$c) = @_; $t = ' ' . $t while length($t) < $c; $t; }

diff -ruN SDL_Perl-2.1.3/Build.PL SDL_Perl-2.1.4/Build.PL --- SDL_Perl-2.1.3/Build.PL 2005-10-05 11:25:49.000000000 +0200 +++ SDL_Perl-2.1.4/Build.PL 2006-03-04 14:04:21.000000000 +0100 @@ -10,6 +10,7 @@ use SDL::Build; use YAML; +use YAML::Node; my $sdl_compile_flags = `sdl-config --cflags`; my $sdl_link_flags = `sdl-config --libs`; diff -ruN SDL_Perl-2.1.3/CHANGELOG SDL_Perl-2.1.4/CHANGELOG --- SDL_Perl-2.1.3/CHANGELOG 2005-10-05 11:25:49.000000000 +0200 +++ SDL_Perl-2.1.4/CHANGELOG 2006-03-04 14:04:21.000000000 +0100 @@ -1,6 +1,10 @@ Revision history for Perl extension SDL_perl. +* Mar 3 2006 Tels 77 Tests + - Color.pm: add rgb(), and make new($r,$g,$b) work for speed + - add ColorRGB() to src/SDL.xs + * Oct 4 2004 David J. Goehrig <dgoehrig@cpan.org> - Patched Cygwin.pm - Fixed SDL::Rect documentation diff -ruN SDL_Perl-2.1.3/lib/SDL/Color.pm SDL_Perl-2.1.4/lib/SDL/Color.pm --- SDL_Perl-2.1.3/lib/SDL/Color.pm 2005-10-05 11:25:49.000000000 +0200 +++ SDL_Perl-2.1.4/lib/SDL/Color.pm 2006-03-04 14:04:21.000000000 +0100 @@ -12,8 +12,11 @@ sub new { my $proto = shift; my $class = ref($proto) || $proto; - my $self; + # called like SDL::Color->new($red,$green,$blue); + return bless \SDL::NewColor(@_), $class if (@_ == 3); + + my $self; my (%options) = @_; verify (%options, qw/ -color -surface -pixel -r -g -b /) if $SDL::DEBUG; @@ -33,8 +36,7 @@ } die "Could not create color, ", SDL::GetError(), "\n" unless ($$self); - bless $self,$class; - return $self; + bless $self, $class; } sub DESTROY { @@ -56,19 +58,24 @@ SDL::ColorB($$self,@_); } +sub rgb { + my $self = shift; + SDL::ColorRGB($$self,@_); +} + sub pixel { die "SDL::Color::pixel requires an SDL::Surface" unless !$SDL::DEBUG || $_[1]->isa("SDL::Surface"); SDL::MapRGB(${$_[1]},$_[0]->r(),$_[0]->g(),$_[0]->b()); } -$SDL::Color::black = new SDL::Color -r => 0, -g => 0, -b => 0; -$SDL::Color::white = new SDL::Color -r => 255, -g => 255, -b => 255; -$SDL::Color::red = new SDL::Color -r => 255, -g => 0, -b => 0; -$SDL::Color::blue = new SDL::Color -r => 0, -g => 0, -b => 255; -$SDL::Color::green = new SDL::Color -r => 0, -g => 255, -b => 0; -$SDL::Color::purple = new SDL::Color -r => 255, -g => 0, -b => 255; -$SDL::Color::yellow = new SDL::Color -r => 255, -g => 255, -b => 0; +$SDL::Color::black = SDL::Color->new(0,0,0); +$SDL::Color::white = SDL::Color->new(255,255,255); +$SDL::Color::red = SDL::Color->new(255,0,0); +$SDL::Color::blue = SDL::Color->new(0,0,255); +$SDL::Color::green = SDL::Color->new(0,255,0); +$SDL::Color::purple = SDL::Color->new(255,0,255); +$SDL::Color::yellow = SDL::Color->new(255,255,0); 1; @@ -82,6 +89,8 @@ =head1 SYNOPSIS + $color = SDL::Color->new($red,$green,$blue); # fastest + $color = new SDL::Color ( -r => 0xde, -g => 0xad, -b =>c0 ); $color = new SDL::Color -surface => $app, -pixel => $app->pixel($x,$y); $color = new SDL::Color -color => SDL::NewColor(0xff,0xaa,0xdd); @@ -89,13 +98,18 @@ =head1 DESCRIPTION C<SDL::Color> is a wrapper for display format independent color -representations, with the same interface as L<SDL::Color>. +representations. =head2 new ( -color => ) C<SDL::Color::new> with a C<-color> option will construct a new object referencing the passed SDL_Color*. +=head2 new ($r, $g, $b) + +C<SDL::Color::new> with three color values will construct both a SDL_Color +structure, and the associated object with the specified values. + =head2 new (-r => , -g => , -b => ) C<SDL::Color::new> with C<-r,-g,-b> options will construct both a SDL_Color @@ -113,6 +127,13 @@ the red, green, and blue components respectively. The color value can be set by passing a byte value (0-255) to each function. +=head2 rgb ( $red, $green, $blue ) + +C<SDL::Color::rgb> is an accessor method for the red, green, and blue components +in one go. It will return a list of three values. + +The color value can be set by passing a byte value (0-255) for each color component. + =head2 pixel ( surface ) C<SDL::Color::pixel> takes a C<SDL::Surface> object and r,g,b values, and @@ -122,8 +143,10 @@ David J. Goehrig +Additions by Tels 2006. + =head1 SEE ALSO -L<perl> L<SDL::Surface> +L<perl> and L<SDL::Surface>. =cut diff -ruN SDL_Perl-2.1.3/src/SDL.xs SDL_Perl-2.1.4/src/SDL.xs --- SDL_Perl-2.1.3/src/SDL.xs 2005-10-05 11:25:49.000000000 +0200 +++ SDL_Perl-2.1.4/src/SDL.xs 2006-03-04 14:04:21.000000000 +0100 @@ -1182,6 +1182,20 @@ RETVAL void +ColorRGB ( color, ... ) + SDL_Color *color + PPCODE: + if (items > 1 ) { + color->r = SvIV(ST(1)); + color->g = SvIV(ST(2)); + color->b = SvIV(ST(3)); + } + mXPUSHi( color->r ); + mXPUSHi( color->g ); + mXPUSHi( color->b ); + XSRETURN(3); + +void FreeColor ( color ) SDL_Color *color CODE: diff -ruN SDL_Perl-2.1.3/t/colorpm.t SDL_Perl-2.1.4/t/colorpm.t --- SDL_Perl-2.1.3/t/colorpm.t 2005-10-05 11:25:49.000000000 +0200 +++ SDL_Perl-2.1.4/t/colorpm.t 2006-03-04 14:04:21.000000000 +0100 @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# Copyright (C) 2003 Tels +# Copyright (C) 2003,2006 Tels # Copyright (C) 2004 David J. Goehrig # # basic testing of SDL::Color @@ -13,7 +13,7 @@ use Test::More; -plan ( tests => 10 ); +plan ( tests => 15 ); use_ok( 'SDL::Color' ); @@ -22,6 +22,7 @@ r g b + rgb pixel /); # some basic tests: @@ -32,9 +33,19 @@ is ($color->g(),0, 'g is 0'); is ($color->b(),0, 'b is 0'); +is (join(":", $color->rgb()), '0:0:0', 'r, g and b are 0'); + $color = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff); is (ref($color), 'SDL::Color', 'new was ok'); is ($color->r(),255, 'r is 255'); is ($color->g(),255, 'g is 255'); is ($color->b(),255, 'b is 255'); +is (join(":", $color->rgb()), '255:255:255', 'r, g and b are 255'); +is (join(":", $color->rgb(128,0,80)), '128:0:80', 'r, g and b are set'); +is (join(":", $color->rgb()), '128:0:80', 'r, g and b still set'); + +# test the new new($r,$g,$b) calling style +$color = SDL::Color->new( 255,70,128); +is (join(":", $color->rgb()), '255:70:128', 'r, g and b are set via new($r,$g,$b)'); +

#!/usr/bin/perl -w use SDL; use SDL::Color; use Benchmark; my $color = SDL::Color->new( -r => 128, -g => 80, -b => 90 ); timethese (-5, { 'new(rgb)' => sub { my $rgb = SDL::Color->new(255,128,70); }, 'new(-r -g -b)' => sub { my $rgb = SDL::Color->new(-r => 255, -g => 128, -b =>70); }, 'r(),g(),b()' => sub { my ($r,$g,$b) = ($color->r(),$color->g(),$color->b()); }, 'rgb()' => sub { my ($r,$g,$b) = $color->rgb(); }, 'r(1),g(2),b(3)' => sub { $color->r(1); $color->g(2); $color->b(3); }, 'rgb(1,2,3)' => sub { $color->rgb(1,2,3); }, } );