PageRenderTime 88ms CodeModel.GetById 22ms app.highlight 61ms RepoModel.GetById 1ms app.codeStats 0ms

/t/gfx_primitives.t

http://github.com/PerlGameDev/SDL
Perl | 422 lines | 380 code | 24 blank | 18 comment | 21 complexity | 4b7fd4fc4436ce00ac8f9221366850f8 MD5 | raw file
  1#!perl
  2use strict;
  3use warnings;
  4use SDL;
  5use SDL::Rect;
  6use SDL::Config;
  7use SDL::Video;
  8use SDL::Version;
  9use SDL::Surface;
 10use SDL::PixelFormat;
 11use SDL::GFX;
 12use SDL::GFX::Primitives;
 13use Test::More;
 14
 15use lib 't/lib';
 16use SDL::TestTool;
 17
 18my $videodriver = $ENV{SDL_VIDEODRIVER};
 19$ENV{SDL_VIDEODRIVER} = 'dummy' unless $ENV{SDL_RELEASE_TESTING};
 20
 21if ( !SDL::TestTool->init(SDL_INIT_VIDEO) ) {
 22	plan( skip_all => 'Failed to init video' );
 23} elsif ( !SDL::Config->has('SDL_gfx_primitives') ) {
 24	plan( skip_all => 'SDL_gfx_primitives support not compiled' );
 25}
 26
 27my $v = SDL::GFX::linked_version();
 28isa_ok( $v, 'SDL::Version', '[linked_version]' );
 29printf( "got version: %d.%d.%d\n", $v->major, $v->minor, $v->patch );
 30
 31my $display = SDL::Video::set_video_mode( 640, 480, 32, SDL_ANYFORMAT );
 32my $pixel = SDL::Video::map_RGB( $display->format, 0, 0, 0 );
 33
 34if ( !$display ) {
 35	plan skip_all => 'Couldn\'t set video mode: ' . SDL::get_error();
 36}
 37
 38my $surface = SDL::Surface->new( SDL_SWSURFACE, 640, 480, 32, 0, 0, 0, 0 );
 39SDL::Video::fill_rect(
 40	$surface,
 41	SDL::Rect->new( 0, 0, $surface->w, $surface->h ), $pixel
 42);
 43
 44# pixel tests
 45is( SDL::GFX::Primitives::pixel_color( $surface, 2, 3, 0xFF0000FF ),
 46	0, 'pixel_color'
 47);
 48is( SDL::GFX::Primitives::pixel_RGBA( $surface, 4, 3, 0x00, 0xFF, 0x00, 0xFF ),
 49	0, 'pixel_RGBA'
 50);
 51
 52# demo for pixel functions
 53#SDL::GFX::Primitives::rectangle_color($surface, 3,   4, 125, 106, 0xCCCCCCFF);
 54#SDL::GFX::Primitives::rectangle_color($surface, 3, 116, 125, 218, 0xCCCCCCFF);
 55
 56my $max_x              = 120;
 57my $max_y              = 100;
 58my $max_iterationen    = 400;
 59my $punkt_abstand_x    = 0.015;
 60my $punkt_abstand_y    = 0.015;
 61my $min_cx             = -2.1;
 62my $min_cy             = -1.1;
 63my $max_betrag_quadrat = 4000;
 64
 65my $r = 0xFF;
 66my $g = 0x00;
 67my $b = 0x00;
 68
 69for ( my $x = 0; $x <= $max_x; $x++ ) {
 70	if ( $x < 20 ) {
 71		$g += 12.7;
 72	} elsif ( $x < 40 ) {
 73		$r -= 12.7;
 74	} elsif ( $x < 60 ) {
 75		$r = 0;
 76		$b += 12.7;
 77	} elsif ( $x < 80 ) {
 78		$g -= 12.7;
 79	} elsif ( $x < 100 ) {
 80		$g = 0;
 81		$r += 12.7;
 82	} else {
 83		$b -= 12.7;
 84	}
 85
 86	for ( my $y = 0; $y <= $max_y; $y++ ) {
 87
 88		# fractal
 89		my $iteration = mandel_point(
 90			$min_cx + $x * $punkt_abstand_x,
 91			$min_cy + $y * $punkt_abstand_y
 92		);
 93		my $col = ( $iteration / $max_iterationen * 8192 ) & 0xFF;
 94
 95		SDL::GFX::Primitives::pixel_RGBA(
 96			$surface,   4 + $x, 5 + $y, $col, 0,
 97			256 - $col, 0xFF
 98		);
 99
100		# color picker
101		SDL::GFX::Primitives::pixel_RGBA(
102			$surface, 4 + $x, 117 + $y, $r, $g,
103			$b,       0xFF - 0xFF * $y / $max_y
104		);
105	}
106}
107
108# line tests
109is( SDL::GFX::Primitives::hline_color( $surface, 131, 135, 4, 0x00FF00FF ),
110	0, 'hline_color'
111); # green
112is( SDL::GFX::Primitives::hline_RGBA( $surface, 131, 135, 6, 0xFF, 0xFF, 0x00, 0xFF ),
113	0,
114	'hline_RGBA'
115); # yellow
116is( SDL::GFX::Primitives::vline_color( $surface, 137, 3, 7, 0x0000FFFF ),
117	0, 'vline_color'
118); # blue
119is( SDL::GFX::Primitives::vline_RGBA( $surface, 139, 3, 7, 0xFF, 0x00, 0x00, 0xFF ),
120	0,
121	'vline_RGBA'
122); # red
123
124# hline/vline demo
125#SDL::GFX::Primitives::rectangle_color($surface, 131, 55 + $_ * 20, 253, 67 + $_ * 20, 0xCCCCCCFF) for(0..5);
126#SDL::GFX::Primitives::rectangle_color($surface, 136 + $_ * 20, 50, 148 + $_ * 20, 172, 0xCCCCCCFF) for(0..5);
127SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0xFF000080 ) for ( 56 .. 66 );
128SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0xFFFF0080 ) for ( 76 .. 86 );
129SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0x00FF0080 ) for ( 96 .. 106 );
130SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0x00FFFF80 ) for ( 116 .. 126 );
131SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0x0000FF80 ) for ( 136 .. 146 );
132SDL::GFX::Primitives::hline_color( $surface, 132, 252, $_, 0xFF00FF80 ) for ( 156 .. 166 );
133SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0xFF000080 ) for ( 137 .. 147 );
134SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0xFFFF0080 ) for ( 157 .. 167 );
135SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0x00FF0080 ) for ( 177 .. 187 );
136SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0x00FFFF80 ) for ( 197 .. 207 );
137SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0x0000FF80 ) for ( 217 .. 227 );
138SDL::GFX::Primitives::vline_color( $surface, $_, 51, 171, 0xFF00FF80 ) for ( 237 .. 247 );
139
140# aaline test
141is( SDL::GFX::Primitives::line_color( $surface, 261, 3, 265, 7, 0xFF00FFFF ),
142	0, 'line_color'
143); # pink
144is( SDL::GFX::Primitives::line_RGBA( $surface, 261, 7, 265, 3, 0x00, 0xFF, 0xFF, 0xFF ),
145	0,
146	'line_RGBA'
147); # turquoise
148is( SDL::GFX::Primitives::aaline_color( $surface, 267, 3, 271, 7, 0xFF00FFFF ),
149	0, 'aaline_color'
150); # pink
151is( SDL::GFX::Primitives::aaline_RGBA( $surface, 267, 7, 271, 3, 0x00, 0xFF, 0xFF, 0xFF ),
152	0,
153	'aaline_RGBA'
154); # turquoise
155
156# aaline demo
157my $last_x   = 287;
158my $last_y   = 62;
159my @points_x = (
160	309, 333, 355, 372, 380, 380, 371, 354,
161	332, 308, 286, 269, 261, 261, 270, 287
162);
163my @points_y = ( 53, 53, 62, 79, 101, 125, 147, 164, 173, 173, 163, 146, 124, 100, 78, 62 );
164
165for my $p1 ( 0 .. 15 ) {
166	for my $p2 ( 0 .. 15 ) {
167		SDL::GFX::Primitives::aaline_color(
168			$surface,       $points_x[$p1], $points_y[$p1],
169			$points_x[$p2], $points_y[$p2], 0xFFFFFF50
170		);
171	}
172}
173
174# rectangle/box demo
175#SDL::GFX::Primitives::rectangle_RGBA($surface, 260 + $_ * 2, 5 + $_ / 120 * 100, 380 - $_ * 2, 105 - $_ / 120 * 100, $_ / 60 * 256, 0, 0, 0xFF) for(0..60);
176#SDL::GFX::Primitives::box_RGBA($surface, 260 + $_, 117 + $_ / 120 * 100, 380 - $_, 217 - $_ / 120 * 100, $_ / 120 * 256, 0, 0, 0x08) for(0..120);
177
178# rectangle/box test
179is( SDL::GFX::Primitives::rectangle_color( $surface, 390, 3, 394, 7, 0x00FF00FF ),
180	0,
181	'rectangle_color'
182); # green
183is( SDL::GFX::Primitives::rectangle_RGBA( $surface, 396, 3, 400, 7, 0xFF, 0xFF, 0x00, 0xFF ),
184	0,
185	'rectangle_RGBA'
186); # yellow
187is( SDL::GFX::Primitives::box_color( $surface, 402, 3, 406, 7, 0x0000FFFF ),
188	0, 'rectangle_color'
189); # blue
190is( SDL::GFX::Primitives::box_RGBA( $surface, 408, 3, 412, 7, 0xFF, 0x00, 0x00, 0xFF ),
191	0,
192	'rectangle_RGBA'
193); # red
194
195# rectangle/box demo
196my @box = (
197	[   '0', '0', '0', '0', '0', '0', '0', '0',
198		'0', '0', '0', '0', '0', '0', '0'
199	],
200	[   '0',  '0', '0', '0', '0', '0', '/', '_',
201		'\\', '0', '0', '0', '0', '0', '0'
202	],
203	[   '0',  '0',  '0',  '0', '/', '/', '/', '_',
204		'\\', '\\', '\\', '0', '0', '0', '0'
205	],
206	[   '0',  '0',  '0',  '/',  '/', '/', '/', '_',
207		'\\', '\\', '\\', '\\', '0', '0', '0'
208	],
209	[   '0',  '0',  '/',  '/',  '/',  '/', '/', '_',
210		'\\', '\\', '\\', '\\', '\\', '0', '0'
211	],
212	[   '0',  '0',  '/',  '/',  '/',  '/', '/', '_',
213		'\\', '\\', '\\', '\\', '\\', '0', '0'
214	],
215	[   '0',  '/',  '/',  '/',  '/',  '/',  '/', '_',
216		'\\', '\\', '\\', '\\', '\\', '\\', '0'
217	],
218	[   '0', '<', '<', '<', '<', '<', '<', '0',
219		'>', '>', '>', '>', '>', '>', '0'
220	],
221	[   '0', '\\', '\\', '\\', '\\', '\\', '\\', '-',
222		'/', '/',  '/',  '/',  '/',  '/',  '0'
223	],
224	[   '0', '0', '\\', '\\', '\\', '\\', '\\', '-',
225		'/', '/', '/',  '/',  '/',  '0',  '0'
226	],
227	[   '0', '0', '\\', '\\', '\\', '\\', '\\', '-',
228		'/', '/', '/',  '/',  '/',  '0',  '0'
229	],
230	[   '0', '0', '0', '\\', '\\', '\\', '\\', '-',
231		'/', '/', '/', '/',  '0',  '0',  '0'
232	],
233	[   '0', '0', '0', '0', '\\', '\\', '\\', '-',
234		'/', '/', '/', '0', '0',  '0',  '0'
235	],
236	[   '0', '0', '0', '0', '0', '\\', '\\', '-',
237		'/', '/', '0', '0', '0', '0',  '0'
238	],
239	[   '0', '0', '0', '0', '0', '0', '0', '0',
240		'0', '0', '0', '0', '0', '0', '0'
241	]
242);
243
244for my $y ( 0 .. 14 ) {
245	for my $x ( 0 .. 14 ) {
246		my $x_pos    = 390 + $x * 8;
247		my $y_pos    = 53 + $y * 8;
248		my $bg_color = ( ( $y & 1 ) ^ ( $x & 1 ) ) ? 0xFFFFFFFF : 0x333333FF;
249		my $fg_color = ( ( $y & 1 ) ^ ( $x & 1 ) ) ? 0x333333FF : 0xFFFFFFFF;
250		SDL::GFX::Primitives::box_color(
251			$surface,   $x_pos, $y_pos, $x_pos + 7,
252			$y_pos + 7, $bg_color
253		);
254
255		if ( @{ $box[$y] }[$x] =~ /[\-_]/ ) {
256			SDL::GFX::Primitives::box_color(
257				$surface, $x_pos + 1,
258				$y_pos + ( $y < 7 ? 5 : 1 ),
259				$x_pos + 2, $y_pos + ( $y < 7 ? 6 : 2 ), $fg_color
260			);
261			SDL::GFX::Primitives::box_color(
262				$surface, $x_pos + 5,
263				$y_pos + ( $y < 7 ? 5 : 1 ),
264				$x_pos + 6, $y_pos + ( $y < 7 ? 6 : 2 ), $fg_color
265			);
266		}
267
268		if ( @{ $box[$y] }[$x] =~ /[<>]/ ) {
269			SDL::GFX::Primitives::box_color(
270				$surface, $x_pos + ( $x < 7 ? 5 : 1 ),
271				$y_pos + 1, $x_pos + ( $x < 7 ? 6 : 2 ),
272				$y_pos + 2, $fg_color
273			);
274			SDL::GFX::Primitives::box_color(
275				$surface, $x_pos + ( $x < 7 ? 5 : 1 ),
276				$y_pos + 5, $x_pos + ( $x < 7 ? 6 : 2 ),
277				$y_pos + 6, $fg_color
278			);
279		}
280
281		if ( @{ $box[$y] }[$x] =~ /\\/ ) {
282			SDL::GFX::Primitives::box_color(
283				$surface,   $x_pos + 1, $y_pos + 1, $x_pos + 2,
284				$y_pos + 2, $fg_color
285			);
286			SDL::GFX::Primitives::box_color(
287				$surface,   $x_pos + 5, $y_pos + 5, $x_pos + 6,
288				$y_pos + 6, $fg_color
289			);
290		}
291		if ( @{ $box[$y] }[$x] =~ /\// ) {
292			SDL::GFX::Primitives::box_color(
293				$surface,   $x_pos + 5, $y_pos + 1, $x_pos + 6,
294				$y_pos + 2, $fg_color
295			);
296			SDL::GFX::Primitives::box_color(
297				$surface,   $x_pos + 1, $y_pos + 5, $x_pos + 2,
298				$y_pos + 6, $fg_color
299			);
300		}
301	}
302}
303
304# circle/arc/aacircle/filled_circle/pie/filled_pie test
305is( SDL::GFX::Primitives::circle_color( $surface, 520, 5, 2, 0x00FF00FF ),
306	0, 'circle_color'
307); # green
308is( SDL::GFX::Primitives::circle_RGBA( $surface, 527, 5, 2, 0xFF, 0xFF, 0x00, 0xFF ),
309	0,
310	'circle_RGBA'
311); # yellow
312is( SDL::GFX::Primitives::aacircle_color( $surface, 534, 5, 2, 0x00FF00FF ),
313	0, 'aacircle_color'
314); # green
315is( SDL::GFX::Primitives::aacircle_RGBA( $surface, 541, 5, 2, 0xFF, 0xFF, 0x00, 0xFF ),
316	0,
317	'aacircle_RGBA'
318); # yellow
319is( SDL::GFX::Primitives::filled_circle_color( $surface, 548, 5, 2, 0x00FF00FF ),
320	0,
321	'filled_circle_color'
322); # green
323is( SDL::GFX::Primitives::filled_circle_RGBA( $surface, 555, 5, 2, 0xFF, 0xFF, 0x00, 0xFF ),
324	0,
325	'filled_circle_RGBA'
326); # yellow
327SKIP:
328{
329	skip( 'Version 2.0.17 needed', 2 ) if $v < 2.0.17;
330	is( SDL::GFX::Primitives::arc_color( $surface, 562, 5, 2, 5, 175, 0x00FF00FF ),
331		0,
332		'arc_color'
333	); # green
334	is( SDL::GFX::Primitives::arc_RGBA( $surface, 569, 5, 2, 185, 355, 0xFF, 0xFF, 0x00, 0xFF ),
335		0,
336		'arc_RGBA'
337	); # yellow
338}
339is( SDL::GFX::Primitives::pie_color( $surface, 576, 7, 5, 270, 0, 0xFF0000FF ),
340	0, 'pie_color'
341);     # red
342is( SDL::GFX::Primitives::pie_RGBA( $surface, 583, 7, 5, 270, 0, 0x00, 0x00, 0xFF, 0xFF ),
343	0,
344	'pie_RGBA'
345);     # blue
346is( SDL::GFX::Primitives::filled_pie_color( $surface, 590, 7, 5, 270, 0, 0xFF0000FF ),
347	0,
348	'filled_pie_color'
349);     # red
350is( SDL::GFX::Primitives::filled_pie_RGBA( $surface, 597, 7, 5, 270, 0, 0x00, 0x00, 0xFF, 0xFF ),
351	0,
352	'filled_pie_RGBA'
353);     # blue
354
355# circle/arc/aacircle/filled_circle/pie/filled_pie demo
356SDL::GFX::Primitives::filled_circle_color( $surface, 553, 137, 36, 0x00FF0080 );
357SDL::GFX::Primitives::filled_circle_color( $surface, 601, 137, 36, 0x0000FF80 );
358SDL::GFX::Primitives::filled_circle_color( $surface, 577, 87,  36, 0xFF000080 );
359if ( $v->major >= 2 && $v->minor >= 0 && $v->patch >= 17 ) {
360	SDL::GFX::Primitives::arc_color(
361		$surface, 553, 137, 36, 310, 335,
362		0xFFFFFF80
363	);
364	SDL::GFX::Primitives::arc_color(
365		$surface, 601, 137, 36, 205, 230,
366		0xFFFFFF80
367	);
368	SDL::GFX::Primitives::arc_color(
369		$surface, 577, 87, 36, 75, 105,
370		0xFFFFFF80
371	);
372	SDL::GFX::Primitives::arc_color(
373		$surface, 553, 137, 36, 48, 255,
374		0xFFFFFF80
375	);
376	SDL::GFX::Primitives::arc_color(
377		$surface, 601, 137, 36, 285, 132,
378		0xFFFFFF80
379	);
380	SDL::GFX::Primitives::arc_color(
381		$surface, 577, 87, 36, 155, 25,
382		0xFFFFFF80
383	);
384}
385SDL::Video::blit_surface(
386	$surface, SDL::Rect->new( 0, 0, 640, 480 ),
387	$display, SDL::Rect->new( 0, 0, 640, 480 )
388);
389SDL::Video::update_rect( $display, 0, 0, 640, 480 );
390
391SDL::delay(3000);
392
393if ($videodriver) {
394	$ENV{SDL_VIDEODRIVER} = $videodriver;
395} else {
396	delete $ENV{SDL_VIDEODRIVER};
397}
398
399pass 'Are we still alive? Checking for segfaults';
400
401done_testing;
402
403sub mandel_point {
404	my $cx = shift;
405	my $cy = shift;
406
407	my $betrag_quadrat = 0;
408	my $iter           = 0;
409	my $x              = 0;
410	my $y              = 0;
411
412	while ( $betrag_quadrat <= $max_betrag_quadrat && $iter < $max_iterationen ) {
413		my $xt = $x * $x - $y * $y + $cx;
414		my $yt = 2 * $x * $y + $cy;
415		$x = $xt;
416		$y = $yt;
417		$iter++;
418		$betrag_quadrat = $x * $x + $y * $y;
419	}
420
421	return $iter;
422}