/t/gfx_primitives.t

http://github.com/PerlGameDev/SDL · Perl · 422 lines · 364 code · 38 blank · 20 comment · 34 complexity · 4b7fd4fc4436ce00ac8f9221366850f8 MD5 · raw file

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