/[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

Annotation of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26