PageRenderTime 59ms CodeModel.GetById 44ms app.highlight 13ms RepoModel.GetById 1ms app.codeStats 0ms

/examples/cookbook/pdl.pl

http://github.com/PerlGameDev/SDL
Perl | 92 lines | 73 code | 19 blank | 0 comment | 6 complexity | dc2fa19974c636e4f3cbabe8744475d2 MD5 | raw file
 1use strict;
 2use warnings;
 3use SDL 2.408;
 4
 5use SDLx::App; #this is in the github repo.
 6use SDL::Event;
 7use SDL::Events;
 8use SDL::Rect;
 9use SDL::Video;
10use SDL::Surface;
11use SDL::PixelFormat;
12use SDL::Palette;
13use SDL::Color;
14use Devel::Peek;
15
16use PDL;
17
18my $app = SDLx::App->new(
19	title  => 'Application Title',
20	width  => 640,
21	height => 480,
22	depth  => 32
23);
24my $mapped_color = SDL::Video::map_RGB( $app->format(), 50, 50, 50 ); # blue
25
26load_app();
27
28my ( $piddle, $surface ) = surf_piddle();
29my $ref = $surface->get_pixels_ptr();
30
31my $event = SDL::Event->new;                                          # create a new event
32
33while (1) {
34	SDL::Events::pump_events();
35
36	while ( SDL::Events::poll_event($event) ) {
37		my $type = $event->type();                                    # get event type
38		exit if $type == SDL_QUIT;
39	}
40	update($piddle);
41
42	SDL::Video::update_rect( $app, 0, 0, $app->w, $app->h );
43}
44
45sub load_app {
46
47	SDL::Video::fill_rect(
48		$app, SDL::Rect->new( 0, 0, $app->w, $app->h ),
49		$mapped_color
50	);
51	return $app;
52}
53
54sub surf_piddle {
55	my ( $bytes_per_pixel, $width, $height ) = ( 4, 400, 200 );
56	my $piddle  = zeros( byte, $bytes_per_pixel, $width, $height );
57	my $pointer = $piddle->get_dataref();
58	my $surface = SDL::Surface->new_from(
59		$pointer, $width, $height, 32,
60		$width * $bytes_per_pixel
61	);
62
63	warn "Made surface of $width, $height and " . $surface->format->BytesPerPixel;
64	return ( $piddle, $surface );
65
66}
67
68sub update {
69	my $piddle = shift;
70	load_app();
71
72	SDL::Video::lock_surface($surface);
73
74	$piddle->mslice(
75		'X',
76		[ rand(400), rand(400), 1 ],
77		[ rand(200), rand(200), 1 ]
78	) .= pdl( rand(225), rand(225), rand(255), 255 );
79
80	SDL::Video::unlock_surface($surface);
81
82	my $b = SDL::Video::blit_surface(
83		$surface,
84		SDL::Rect->new( 0, 0, $surface->w, $surface->h ),
85		$app,
86		SDL::Rect->new(
87			( $app->w - $surface->w ) / 2, ( $app->h - $surface->h ) / 2,
88			$app->w, $app->h
89		)
90	);
91	die "Could not blit: " . SDL::get_error() if ( $b == -1 );
92}