/[VRac]/Screen.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 171 - (show annotations)
Mon Aug 6 11:40:21 2007 UTC (13 years, 3 months ago) by dpavlin
File size: 7649 byte(s)
Simplified and in process fixed keyboard handling for multiple pressed keys
1 package Screen;
2
3 # Dobrica Pavlinusic, <dpavlin@rot13.org> 07/30/07 17:58:55 CEST
4
5 use strict;
6 use warnings;
7
8 use SDL::App;
9 use SDL::Rect;
10 use SDL::Color;
11 use SDL::Constants;
12
13 use Carp qw/confess/;
14 use Data::Dump qw/dump/;
15
16 use Exporter 'import';
17 our @EXPORT = qw'$white $black @flip';
18
19 use base qw(Class::Accessor Prefs);
20 __PACKAGE__->mk_accessors(qw(app event));
21
22 =head1 NAME
23
24 Screen - simulated 256*256 pixels monochrome screen using SDL
25
26 =head1 Architecture dependent
27
28 You may override following methods if you want to implement keyboard on each
29 keypress event. Alternative is to use <read> hook and trap memory access.
30
31 =head2 key_down
32
33 $self->key_down( 'a' );
34
35 =cut
36
37 sub key_down {}
38
39 =head2 key_up
40
41 $self->key_up( 'a' );
42
43 =cut
44
45 sub key_up {}
46
47
48 =head1 Architecture independent
49
50 You don't need to override any of following function in your architecture,
51 but you might want to call them.
52
53 =head2 open_screen
54
55 Open simulated screen
56
57 =cut
58
59 our $app;
60
61 sub open_screen {
62 my $self = shift;
63
64 $self->prefs;
65
66 if ( ! $self->scale ) {
67 $self->scale( 1 );
68 warn "using default unscaled display\n";
69 }
70
71 $app = SDL::App->new(
72 -width => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
73 -height => 256 * $self->scale,
74 -depth => 16,
75 -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
76 );
77 #$app->grab_input( SDL_GRAB_QUERY );
78 $app->grab_input( SDL_GRAB_OFF );
79 $app->title( ref($self) );
80
81 $self->app( $app );
82
83 my $event = SDL::Event->new();
84 $self->event( $event );
85
86 warn "# created SDL::App\n";
87 }
88
89 our $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
90 our $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
91
92 my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
93 my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
94 my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
95
96 =head2 mem_xy
97
98 Helper to return x and y coordinates in memory map
99
100 my ( $x,$y ) = $screen->mem_xy( $address );
101
102 =cut
103
104 sub mem_xy {
105 my $self = shift;
106 my $offset = shift;
107 my $x = $offset & 0xff;
108 $x += 256 * $self->scale;
109 my $y = $offset >> 8;
110 return ($x,$y);
111 }
112
113 =head2 mmap_pixel
114
115 Draw pixel in memory map
116
117 $self->mmap_pixel( $addr, $r, $g, $b );
118
119 =cut
120
121 # keep accesses to memory
122 my $_mem_stat;
123
124 sub mmap_pixel {
125 my ( $self, $addr, $r, $g, $b ) = @_;
126 return unless $self->show_mem && $self->app;
127
128 my ( $x, $y ) = $self->mem_xy( $addr );
129 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
130
131 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
132 $self->app->pixel( $x, $y, $col );
133
134 $_mem_stat++;
135 if ( $_mem_stat % 1000 == 0 ) {
136 $self->app->sync;
137 }
138 }
139
140
141 =head2 sync
142
143 $self->sync;
144
145 =cut
146
147 sub sync {
148 $app->sync;
149 }
150
151 =head2 render_vram
152
153 Render one frame of video ram
154
155 $self->render_vram;
156
157 =cut
158
159 sub render_vram {
160 my $self = shift;
161
162 confess "please implement $self::render_vram";
163 }
164
165
166 =head2 render_frame
167
168 Render one frame of video ram
169
170 $self->render_frame( $vram_sdl_surface );
171
172 =cut
173
174 sub render_frame {
175 my $self = shift;
176
177 my $vram = shift;
178 confess "need SDL::Surface as argument" unless ref($vram) eq 'SDL::Surface';
179
180 $vram->display_format;
181
182 my $scale = $self->scale || confess "no scale?";
183
184 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );
185 my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );
186
187 if ( $scale > 1 ) {
188 use SDL::Tool::Graphic;
189 # last parametar is anti-alias
190 my $zoomed = SDL::Tool::Graphic->zoom( $vram, $self->scale, $self->scale, 1 );
191 $zoomed->blit( $rect, $app, $rect_screen );
192 } else {
193 $vram->blit( $rect, $app, $rect_screen );
194 }
195
196 $app->sync;
197 }
198
199
200 =head2 render_mem
201
202 $self->render_mem( @mem );
203
204 =cut
205
206 sub render_mem {
207 my $self = shift;
208
209 return unless $self->show_mem;
210
211 my $pixels = pack("C*", @_);
212
213 my $vram = SDL::Surface->new(
214 -width => 256,
215 -height => 256,
216 -depth => 8, # 1 bit per pixel
217 -pitch => 256, # bytes per line
218 -from => $pixels,
219 -Rmask => 0xffff00ff,
220 -Gmask => 0xffff00ff,
221 -Bmask => 0xffff00ff,
222 );
223
224 $vram->display_format;
225
226 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
227 my $rect_mem = SDL::Rect->new( -x => 256 * $self->scale, -y => 0, -width => 256, -height => 256 );
228
229 $vram->blit( $rect, $app, $rect_mem );
230
231 $app->sync;
232 }
233
234 =head2 key_pressed
235
236 Check SDL event loop if there are any pending keys
237
238 my $key = $self->key_pressed;
239
240 if ( $self->key_pressed( 1 ) ) {
241 # just to check other events, don't process
242 # key
243 }
244
245 =cut
246
247 my $pending_key;
248 my $key_active;
249 my $run_for = 2000;
250
251 sub key_pressed {
252 my $self = shift;
253
254 # don't take key, just pull event
255 my $just_checking = shift || 0;
256
257 my $event = $self->event || confess "no event?";
258
259 if ( ! $event->poll ) {
260 return $pending_key unless $self->can('session_event');
261 if ( my $h = $self->session_event('key_pressed') ) {
262 my ( $key, $state ) = %$h;
263 if ( $state ) {
264 $pending_key = $key;
265 $self->key_down( $key );
266 $key_active->{$key} = 1;
267 } else {
268 undef $pending_key;
269 $self->key_up( $key );
270 $key_active->{$key} = 0;
271 }
272 }
273 return $pending_key;
274 }
275
276 my $type = $event->type();
277
278 exit if ($type == SDL_QUIT);
279
280 my $k = $pending_key;
281
282 if ($type == SDL_KEYDOWN) {
283 $k = $event->key_name();
284 if ( $k eq 'escape' ) {
285 $run_for = $self->cli;
286 warn "will check event loop every $run_for cycles\n";
287 $pending_key = '~';
288 } else {
289 warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";
290 $pending_key = $k;
291 $self->key_down( $k );
292 $key_active->{$k} = 1;
293 $self->record_session('key_pressed', { $k => 1 });
294 }
295 } elsif ( $type == SDL_KEYUP ) {
296 my $up = $event->key_name();
297 warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
298 $self->key_up( $up );
299 $key_active->{$up} = 0;
300 $self->record_session('key_pressed', { $up => 0 });
301 undef $pending_key;
302 }
303
304 warn "key_pressed = $pending_key\n" if ( $pending_key );
305
306 return $pending_key;
307 }
308
309 =head2 key_active
310
311 Is key currently pressed on keyboard or in session?
312
313 $self->key_active( 'left shift', 'right shift', 'a' );
314
315 =cut
316
317 sub key_active {
318 my $self = shift;
319 my @keys = @_;
320 confess "Regexp is no longer supported" if ref($_[0]) eq 'Regexp';
321
322 my $active = 0;
323 foreach my $key ( @keys ) {
324 $active++ if $key_active->{$key};
325 }
326
327 warn "## key_active(",dump(@keys),") = $active\n" if $active;
328 return $active;
329 }
330
331 =head2 loop
332
333 Implement CPU run for C<$run_run> cycles inside SDL event loop
334
335 $self->loop( sub {
336 my $run_for = shift;
337 CPU::exec( $run_for );
338 $self->render_vram;
339 } );
340
341 =cut
342
343 sub loop {
344 my $self = shift;
345 my $exec = shift;
346
347 confess "need coderef as argument" unless ref($exec) eq 'CODE';
348 my $event = SDL::Event->new();
349
350 while ( 1 ) {
351 $self->key_pressed( 1 );
352 $exec->($run_for);
353 }
354 }
355
356 # helper array to flip bytes for display
357 our @flip;
358
359 foreach my $i ( 0 .. 255 ) {
360 my $t = 0;
361 $i & 0b00000001 and $t = $t | 0b10000000;
362 $i & 0b00000010 and $t = $t | 0b01000000;
363 $i & 0b00000100 and $t = $t | 0b00100000;
364 $i & 0b00001000 and $t = $t | 0b00010000;
365 $i & 0b00010000 and $t = $t | 0b00001000;
366 $i & 0b00100000 and $t = $t | 0b00000100;
367 $i & 0b01000000 and $t = $t | 0b00000010;
368 $i & 0b10000000 and $t = $t | 0b00000001;
369 #warn "$i = $t\n";
370 $flip[$i] = $t;
371 }
372
373 =head1 SEE ALSO
374
375 L<Orao> is sample implementation using this module
376
377 =head1 AUTHOR
378
379 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
380
381 =head1 COPYRIGHT & LICENSE
382
383 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
384
385 This program is free software; you can redistribute it and/or modify it
386 under the same terms as Perl itself.
387
388 =cut
389
390 1;

  ViewVC Help
Powered by ViewVC 1.1.26