PageRenderTime 71ms CodeModel.GetById 19ms app.highlight 49ms RepoModel.GetById 1ms app.codeStats 0ms

/t_backcompat/testgfxprim.pl

http://github.com/PerlGameDev/SDL
Perl | 273 lines | 184 code | 59 blank | 30 comment | 15 complexity | 63928644505a6c9ab35882732ac03603 MD5 | raw file
  1#!/usr/bin/env perl
  2#
  3# testgfxprim.pl
  4#
  5# This tests low level usage of the SDL_gfx extension.
  6# Therefore, you should *not* rely on *any* part of this API.
  7# It is subject to change, and will eventually
  8# be encapsulated by something such as SDL::GraphicTool
  9#
 10# (plus, it's a bitch to use like this anyway)
 11#
 12
 13# Usage: testgfxprm.pl [-bpp N] [-hw] [-fast] [-fullscreen]
 14
 15use strict;
 16use Getopt::Long;
 17use Data::Dumper;
 18
 19use SDL;
 20use SDLx::App;
 21use SDL::Event;
 22use SDL::Surface;
 23use SDL::Color;
 24use SDL::Rect;
 25use SDL::Config;
 26
 27use vars qw/ $app $app_rect $background $event $sprite $sprite_rect $videoflags /;
 28
 29die "Your system is not configured with SDL_gfx support!\n"
 30	unless ( SDL::Config->has('SDL_gfx') );
 31
 32## User tweakable settings (via cmd-line)
 33my %settings = (
 34	'numsprites'    => 10,
 35	'screen_width'  => 640,
 36	'screen_height' => 480,
 37	'video_bpp'     => 8,
 38	'fast'          => 0,
 39	'hw'            => 0,
 40	'fullscreen'    => 0,
 41	'bpp'           => undef,
 42);
 43
 44## Process commandline arguments
 45
 46sub get_cmd_args {
 47	GetOptions(
 48		"width:i"      => \$settings{screen_width},
 49		"height:i"     => \$settings{screen_height},
 50		"bpp:i"        => \$settings{bpp},
 51		"fast!"        => \$settings{fast},
 52		"hw!"          => \$settings{hw},
 53		"fullscreen!"  => \$settings{fullscreen},
 54		"numsprites=i" => \$settings{numsprites},
 55	);
 56}
 57
 58## Initialize application options
 59
 60sub set_app_args {
 61	$settings{bpp} ||= 8; # default to 8 bits per pix
 62
 63	$videoflags |= SDL_HWACCEL    if $settings{hw};
 64	$videoflags |= SDL_FULLSCREEN if $settings{fullscreen};
 65}
 66
 67## Setup
 68
 69sub init_game_context {
 70	$app = SDLx::App->new(
 71		-width  => $settings{screen_width},
 72		-height => $settings{screen_height},
 73		-title  => "testsprite",
 74		-icon   => "data/icon.bmp",
 75		-flags  => $videoflags
 76	);
 77
 78	$app_rect = SDL::Rect->new(
 79		-height => $settings{screen_height},
 80		-width  => $settings{screen_width}
 81	);
 82
 83	$background = $SDL::Color::black;
 84
 85	$sprite = SDL::Surface->new( -name => "data/icon.bmp" );
 86
 87	# Set transparent pixel as the pixel at (0,0)
 88	$sprite->set_color_key( SDL_SRCCOLORKEY, $sprite->pixel( 0, 0 ) );
 89
 90	print STDERR "Got past that\n";
 91
 92	$sprite->display_format();
 93
 94	$sprite_rect = SDL::Rect->new(
 95		-x      => 0,
 96		-y      => 0,
 97		-width  => $sprite->width,
 98		-height => $sprite->height
 99	);
100
101	$event = SDL::Event->new();
102}
103
104## Prints diagnostics
105
106sub instruments {
107	if ( ( $app->flags & SDL_HWSURFACE ) == SDL_HWSURFACE ) {
108		printf("Screen is in video memory\n");
109	} else {
110		printf("Screen is in system memory\n");
111	}
112
113	if ( ( $app->flags & SDL_DOUBLEBUF ) == SDL_DOUBLEBUF ) {
114		printf("Screen has double-buffering enabled\n");
115	}
116
117	if ( ( $sprite->flags & SDL_HWSURFACE ) == SDL_HWSURFACE ) {
118		printf("Sprite is in video memory\n");
119	} else {
120		printf("Sprite is in system memory\n");
121	}
122
123	# Run a sample blit to trigger blit (if posssible)
124	# acceleration before the check just after
125	$sprite->blit( 0, $app, 0 );
126
127	if ( ( $sprite->flags & SDL_HWACCEL ) == SDL_HWACCEL ) {
128		printf("Sprite blit uses hardware acceleration\n");
129	}
130	if ( ( $sprite->flags & SDL_RLEACCEL ) == SDL_RLEACCEL ) {
131		printf("Sprite blit uses RLE acceleration\n");
132	}
133
134}
135
136sub game_loop {
137	my $surf          = $$app;
138	my $surfWidth     = $settings{screen_width};
139	my $surfHeight    = $settings{screen_height};
140	my $surfMidWidth  = $settings{screen_width} >> 1;
141	my $surfMidHeight = $settings{screen_height} >> 1;
142
143	$app->fill( $app_rect, $background );
144
145	# TODO: polygon's, GFX*Color
146
147	#lines
148
149	SDL::GFXHlineRGBA(
150		$surf, 0, $surfWidth, $surfMidHeight, 255, 255, 255,
151		255
152	);
153
154	SDL::GFXVlineRGBA(
155		$surf, $surfMidWidth, 0, $surfHeight, 255, 255, 255,
156		255
157	);
158
159	# rectangles
160
161	SDL::GFXRectangleRGBA(
162		$surf, 0, 0,
163		$surfMidWidth / 2,
164		$surfMidHeight / 2,
165		255, 0, 0, 255
166	);
167
168	SDL::GFXBoxRGBA(
169		$surf, 0, 0,
170		$surfMidWidth / 3,
171		$surfMidHeight / 3,
172		0, 255, 0, 255
173	);
174
175	SDL::GFXLineRGBA( $surf, 0, 0, $surfWidth, $surfHeight, 0, 255, 255, 255 );
176
177	SDL::GFXAalineRGBA(
178		$surf, $surfWidth, 0, 0, $surfHeight, 0, 255, 255,
179		255
180	);
181
182	# circles
183
184	SDL::GFXCircleRGBA(
185		$surf,          $surfMidWidth * .3,
186		$surfMidHeight, $surfMidWidth * .3,
187		255, 255, 0, 255
188	);
189
190	SDL::GFXAacircleRGBA(
191		$surf,          $surfMidWidth * .6,
192		$surfMidHeight, $surfMidWidth * .3,
193		255, 255, 0, 255
194	);
195
196	SDL::GFXFilledCircleRGBA(
197		$surf,          $surfMidWidth * .3,
198		$surfMidHeight, $surfMidWidth * .25,
199		255, 255, 0, 255
200	);
201
202	# ellipses
203
204	SDL::GFXEllipseRGBA(
205		$surf, $surfWidth - $surfMidWidth * .3,
206		$surfMidHeight,
207		$surfMidWidth * .3,
208		$surfMidHeight * .15,
209		255, 255, 0, 255
210	);
211
212	SDL::GFXAaellipseRGBA(
213		$surf, $surfWidth - $surfMidWidth * .6,
214		$surfMidHeight,
215		$surfMidWidth * .3,
216		$surfMidHeight * .15,
217		255, 255, 0, 255
218	);
219
220	SDL::GFXFilledEllipseRGBA(
221		$surf, $surfWidth - $surfMidWidth * .3,
222		$surfMidHeight,
223		$surfMidWidth * .25,
224		$surfMidHeight * .10,
225		255, 255, 0, 255
226	);
227
228	# pie slices
229	SDL::GFXFilledPieRGBA(
230		$surf, $surfMidWidth, $surfMidHeight,
231		$surfMidWidth * .1,
232		0, 90, 0, 0, 255, 255
233	);
234
235	SDL::GFXFilledPieRGBA(
236		$surf, $surfMidWidth, $surfMidHeight,
237		$surfMidWidth * .1,
238		180, 270, 0, 0, 255, 255
239	);
240
241	# polygons
242
243	# TBD...
244
245	# characters & strings
246
247	SDL::GFXCharacterRGBA( $surf, $surfMidWidth, 0, "!", 255, 255, 255, 255 );
248
249	SDL::GFXStringRGBA(
250		$surf, $surfMidWidth,
251		$surfHeight * .75,
252		"SDL_Perl Primitive Test.",
253		255, 255, 255, 255
254	);
255
256	$app->flip();
257
258	$app->loop(
259		{   SDL_QUIT() => sub { exit(0); },
260			SDL_KEYDOWN() =>
261				sub { exit(0) if ( SDL::GetKeyState(SDLK_ESCAPE) ); },
262		}
263	);
264}
265
266## Main program loop
267
268get_cmd_args();
269set_app_args();
270init_game_context();
271instruments();
272game_loop();
273