test/testgfxprim.sdlpl

   1 #!/usr/bin/env perl
   2 #
   3 # testgfxprim.pl
   4 #
   5 # Copyright (C) 2005 David J. Goehrig <dgoehrig@cpan.org>
   6 #
   7 # ------------------------------------------------------------------------------
   8 #
   9 # This library is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU Lesser General Public
  11 # License as published by the Free Software Foundation; either
  12 # version 2.1 of the License, or (at your option) any later version.
  13 #
  14 # This library is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # Lesser General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU Lesser General Public
  20 # License along with this library; if not, write to the Free Software
  21 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  22 #
  23 # ------------------------------------------------------------------------------
  24 #
  25 # Please feel free to send questions, suggestions or improvements to:
  26 #
  27 #       David J. Goehrig
  28 #       dgoehrig@cpan.org
  29 #
  30
  31 use strict;
  32 use Getopt::Long;
  33 use Data::Dumper;
  34 use MIME::Base64 qw(decode_base64);
  35
  36 use SDL;
  37 use SDL::App;
  38 use SDL::Event;
  39 use SDL::Surface;
  40 use SDL::Color;
  41 use SDL::Rect;
  42 use SDL::Config;
  43
  44 use vars qw/ $app $app_rect $background $event $sprite $sprite_rect $videoflags /;
  45
  46 die "Your system is not configured with SDL_gfx support!\n"
  47         unless (SDL::Config->has('SDL_gfx'));
  48
  49 ## User tweakable settings (via cmd-line)
  50 my %settings = (
  51         'numsprites'            => 10,
  52         'screen_width'  => 640,
  53         'screen_height' => 480,
  54         'video_bpp'              => 8,
  55         'fast'                                  => 0,
  56         'hw'                                            => 0,
  57         'fullscreen'            => 0,
  58         'bpp'                                    => undef,
  59 );
  60
  61 ## Process commandline arguments
  62
  63 sub get_cmd_args
  64 {
  65         GetOptions(     "width:i"       => \$settings{screen_width},
  66                          "height:i" => \$settings{screen_height},
  67                          "bpp:i"                => \$settings{bpp},
  68                          "fast!"         => \$settings{fast},
  69                          "hw!"           => \$settings{hw},
  70                          "fullscreen!" => \$settings{fullscreen},
  71                          "numsprites=i" => \$settings{numsprites},
  72                 );
  73 }
  74
  75 ## Initialize application options
  76
  77 sub set_app_args
  78 {
  79         $settings{bpp} ||= 8;           # default to 8 bits per pix
  80
  81         $videoflags |= SDL_HWACCEL               if $settings{hw};
  82         $videoflags |= SDL_FULLSCREEN   if $settings{fullscreen};
  83 }
  84
  85 ## Setup
  86
  87 sub init_game_context
  88 {
  89         $app = new SDL::App
  90                         -width => $settings{screen_width},
  91                         -height=> $settings{screen_height},
  92                         -title => "testsprite",
  93                         -flags => $videoflags;
  94
  95         $app_rect= new SDL::Rect
  96                                 -height => $settings{screen_height},
  97                                 -width  => $settings{screen_width};
  98
  99         $background = $SDL::Color::black;
 100
 101         $sprite = new SDL::Surface -name =>"/tmp/icon.bmp";
 102
 103         # Set transparent pixel as the pixel at (0,0)
 104         $sprite->set_color_key(SDL_SRCCOLORKEY,$sprite->pixel(0,0));
 105
 106         print STDERR "Got past that\n";
 107
 108         $sprite->display_format();
 109
 110         $sprite_rect = new SDL::Rect
 111                                 -x => 0,
 112                                 -y => 0,
 113                                 -width => $sprite->width,
 114                                 -height=> $sprite->height;
 115
 116         $event = new SDL::Event();
 117 }
 118
 119 ## Prints diagnostics
 120
 121 sub instruments
 122 {
 123         if ( ($app->flags & SDL_HWSURFACE) == SDL_HWSURFACE ) {
 124                 printf("Screen is in video memory\n");
 125         } else {
 126                 printf("Screen is in system memory\n");
 127         }
 128
 129         if ( ($app->flags & SDL_DOUBLEBUF) == SDL_DOUBLEBUF ) {
 130                 printf("Screen has double-buffering enabled\n");
 131         }
 132
 133         if ( ($sprite->flags & SDL_HWSURFACE) == SDL_HWSURFACE ) {
 134                 printf("Sprite is in video memory\n");
 135         } else {
 136                 printf("Sprite is in system memory\n");
 137         }
 138
 139         # Run a sample blit to trigger blit (if posssible)
 140         # acceleration before the check just after
 141         $sprite->blit(0,$app,0);
 142
 143         if ( ($sprite->flags & SDL_HWACCEL) == SDL_HWACCEL ) {
 144                 printf("Sprite blit uses hardware acceleration\n");
 145         }
 146         if ( ($sprite->flags & SDL_RLEACCEL) == SDL_RLEACCEL ) {
 147                 printf("Sprite blit uses RLE acceleration\n");
 148         }
 149
 150 }
 151
 152 sub game_loop
 153 {
 154         my $surf = $$app;
 155         my $surfWidth=$settings{screen_width};
 156         my $surfHeight=$settings{screen_height};
 157         my $surfMidWidth=$settings{screen_width}>>1;;
 158         my $surfMidHeight=$settings{screen_height}>>1;
 159
 160         $app->fill($app_rect, $background);
 161
 162         # TODO: polygon's, GFX*Color
 163
 164         #lines
 165
 166         SDL::GFXHlineRGBA($surf,
 167                                  0,$surfWidth,
 168                                  $surfMidHeight,
 169                                  255,255,255,255);
 170
 171         SDL::GFXVlineRGBA($surf,
 172                                  $surfMidWidth,
 173                                  0,$surfHeight,
 174                                  255,255,255,255);
 175
 176         # rectangles
 177
 178         SDL::GFXRectangleRGBA($surf,
 179                          0,0,
 180                          $surfMidWidth/2,$surfMidHeight/2,
 181                          255,0,0,255);
 182
 183         SDL::GFXBoxRGBA($surf,
 184                          0,0,
 185                          $surfMidWidth/3,$surfMidHeight/3,
 186                          0,255,0,255);
 187
 188         SDL::GFXLineRGBA($surf,
 189                                 0,0,
 190                                 $surfWidth,$surfHeight,
 191                                 0,255,255,255);
 192
 193         SDL::GFXAalineRGBA($surf, $surfWidth,0,0,$surfHeight,0,255,255,255);
 194
 195         # circles
 196
 197         SDL::GFXCircleRGBA( $surf,$surfMidWidth*.3, $surfMidHeight,
 198                 $surfMidWidth*.3, 255,255,0,255);
 199
 200
 201         SDL::GFXAacircleRGBA($surf, $surfMidWidth*.6, $surfMidHeight,
 202                 $surfMidWidth*.3, 255,255,0,255);
 203
 204
 205         SDL::GFXFilledCircleRGBA($surf,$surfMidWidth*.3, $surfMidHeight,
 206                 $surfMidWidth*.25,255,255,0,255);
 207
 208
 209         # ellipses
 210
 211         SDL::GFXEllipseRGBA($surf,$surfWidth- $surfMidWidth*.3, $surfMidHeight,
 212                 $surfMidWidth*.3,$surfMidHeight*.15, 255,255,0,255);
 213
 214         SDL::GFXAaellipseRGBA($surf,$surfWidth- $surfMidWidth*.6, $surfMidHeight,
 215                 $surfMidWidth*.3,$surfMidHeight*.15,255,255,0,255);
 216
 217         SDL::GFXFilledEllipseRGBA($surf,$surfWidth- $surfMidWidth*.3, $surfMidHeight,
 218                 $surfMidWidth*.25,$surfMidHeight*.10,255,255,0,255);
 219
 220         # pie slices
 221         SDL::GFXFilledPieRGBA($surf,$surfMidWidth,$surfMidHeight, $surfMidWidth*.1,
 222                 0,90,0,0,255,255);
 223
 224         SDL::GFXFilledPieRGBA($surf,$surfMidWidth,$surfMidHeight, $surfMidWidth*.1,
 225                 180,270,0,0,255,255);
 226
 227         # polygons
 228
 229         # TBD...
 230
 231
 232         # characters & strings
 233
 234         SDL::GFXCharacterRGBA($surf,$surfMidWidth,0,
 235                 "!",255,255,255,255);
 236
 237         SDL::GFXStringRGBA($surf,$surfMidWidth,$surfHeight*.75,
 238                 "SDL_Perl Primitive Test.",255,255,255,255);
 239
 240         $app->flip();
 241
 242         $app->loop({
 243                 SDL_QUIT() => sub { exit(0); },
 244                 SDL_KEYDOWN() => sub { exit(0) if (SDL::GetKeyState(SDLK_ESCAPE)); },
 245         });
 246 }
 247
 248 ## Main program loop
 249
 250 write_bmp();
 251 get_cmd_args();
 252 set_app_args();
 253 init_game_context();
 254 instruments();
 255 game_loop();
 256
 257 sub write_bmp {
 258         my $bmp = decode_base64 <<EOF;
 259 Qk1CAgAAAAAAAEIAAAAoAAAAIAAAACAAAAABAAQAAAAAAAACAABtCwAAbQsAAAMAAAADAAAA////
 260 AAAAAAAA//8AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 261 AAAAAAAAAAAAAAAAAAAAAAAAAAAAABEREREAAAAAAAAAAAAAABEiIiIiEQAAAAAAAAAAAAEiIRER
 262 EiIQAAAAAAAAAAASIRERERESIQAAAAAAAAABIhERERERESIQAAAAAAAAEiERIiIiIhESIQAAAAAA
 263 ABIiIiIiIiIiIiEAAAAAAAEiIiIiIiIiIiIiEAAAAAABIiIiIiESIiIiIhAAAAAAASIiIiIhEiIi
 264 IiIQAAAAAAEiIiIiIiIiIiIiEAAAAAABIiIiIiIiIiIiIhAAAAAAASIiEREiIhERIiIQAAAAAAEi
 265 IhEBIiIRASIiEAAAAAAAEiIRESIiEREiIQAAAAAAABIiIiIiIiIiIiEAAAAAAAABIiIiIiIiIiIQ
 266 AAAAAAAAABIiIiIiIiIhAAAAAAAAAAABIiIiIiIiEAAAAAAAAAAAABEiIiIiEQAAAAAAAAAAAAAA
 267 EREREQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 268 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 269 AAAAAAAAAAA=
 270 EOF
 271         open FP, "> /tmp/icon.bmp";
 272         print FP $bmp;
 273         close FP;
 274 }
 275