Skip Menu |
 

This queue is for tickets about the SDL_perl CPAN distribution.

Report information
The Basics
Id: 17975
Status: resolved
Priority: 0/
Queue: SDL_perl

People
Owner: Nobody in particular
Requestors: nospam-abuse [...] bloodgate.com
Cc:
AdminCc:

Bug Information
Severity: Normal
Broken in: (no value)
Fixed in: v2.2.2.5



Subject: Speed up SDL::Color
Download (untitled) / with headers
text/plain 1.5k
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
Subject: filter.pl
Download filter.pl
text/x-perl 411b
#!/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; }
Subject: patch_color.txt
Download patch_color.txt
text/plain 5.9k
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)'); +
Subject: bench.pl
Download bench.pl
text/x-perl 561b
#!/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); }, } );
Download (untitled) / with headers
text/plain 202b
Patched here http://github.com/kthakore/SDL_perl/commit/45f7368964390b1b6e48edfba3dfa4b0d6cc74ce scheduling to add in version 2.2.2. I will also have to add deprecated warnings to the other methods.


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.