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

Diff of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 161 by dpavlin, Sun Aug 5 19:44:20 2007 UTC revision 216 by dpavlin, Thu Sep 3 10:24:34 2009 UTC
# Line 14  use Carp qw/confess/; Line 14  use Carp qw/confess/;
14  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
15    
16  use Exporter 'import';  use Exporter 'import';
17  our @EXPORT = qw'$white $black';  our @EXPORT = qw'$white $black @flip';
18    
19  use base qw(Class::Accessor Prefs);  use base qw(Class::Accessor Prefs);
20  __PACKAGE__->mk_accessors(qw(app event));  __PACKAGE__->mk_accessors(qw(app event screen_width screen_height window_width window_height));
21    
22  =head1 NAME  =head1 NAME
23    
24  Screen - simulated 256*256 pixels monochrome screen using SDL  Screen - simulated monochrome screen using SDL
25    
26  =head1 Architecture dependent  =head1 Architecture dependent
27    
28  You may override following methods if you want to implement keyboard on each  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.  keypress event. Alternative is to use <read> hook and trap memory access.
30    
31    =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  =head2 key_down  =head2 key_down
40    
41    $self->key_down( 'a' );    $self->key_down( 'a' );
# Line 68  sub open_screen { Line 76  sub open_screen {
76                  warn "using default unscaled display\n";                  warn "using default unscaled display\n";
77          }          }
78    
79            $self->screen_width( 256 ) unless defined $self->screen_width;
80            $self->screen_height( 256 ) unless defined $self->screen_height;
81    
82            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          $app = SDL::App->new(          $app = SDL::App->new(
92                  -width  => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),                  -width  => $w,
93                  -height => 256 * $self->scale,                  -height => $h,
94                  -depth  => 16,                  -depth  => 16,
95                  -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,  #               -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
96          );          );
97          #$app->grab_input( SDL_GRAB_QUERY );          #$app->grab_input( SDL_GRAB_QUERY );
98          $app->grab_input( SDL_GRAB_OFF );          $app->grab_input( SDL::App::SDL_GRAB_OFF );
99          $app->title( ref($self) );          $app->title( ref($self) );
100    
101          $self->app( $app );          $self->app( $app );
# Line 83  sub open_screen { Line 103  sub open_screen {
103          my $event = SDL::Event->new();          my $event = SDL::Event->new();
104          $self->event( $event );          $self->event( $event );
105    
106          warn "# created SDL::App\n";          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  }  }
109    
110  our $white      = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );  our $white      = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
# Line 105  sub mem_xy { Line 126  sub mem_xy {
126          my $self = shift;          my $self = shift;
127          my $offset = shift;          my $offset = shift;
128          my $x = $offset & 0xff;          my $x = $offset & 0xff;
129          $x += 256 * $self->scale;          $x += $self->screen_width * $self->scale;
130          my $y = $offset >> 8;          my $y = $offset >> 8;
131          return ($x,$y);          return ($x,$y);
132  }  }
# Line 181  sub render_frame { Line 202  sub render_frame {
202    
203          my $scale = $self->scale || confess "no scale?";          my $scale = $self->scale || confess "no scale?";
204    
205          my $rect        = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );          my $rect        = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width * $scale, -height => $self->screen_height * $scale );
206          my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );          my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width * $scale, -height => $self->screen_height * $scale );
207    
208          if ( $scale > 1 ) {          if ( $scale > 1 ) {
209                  use SDL::Tool::Graphic;                  use SDL::Tool::Graphic;
# Line 200  sub render_frame { Line 221  sub render_frame {
221  =head2 render_mem  =head2 render_mem
222    
223    $self->render_mem( @mem );    $self->render_mem( @mem );
224      $self->render_mem( $memory_bytes );
225    
226  =cut  =cut
227    
# Line 208  sub render_mem { Line 230  sub render_mem {
230    
231          return unless $self->show_mem;          return unless $self->show_mem;
232    
233          my $pixels = pack("C*", @_);          my $pixels;
234            if ( defined $# ) {
235                    $pixels = pack("C*", @_);
236            } else {
237                    $pixels = shift;
238            }
239    
240          my $vram = SDL::Surface->new(          my $vram = SDL::Surface->new(
241                  -width => 256,                  -width => 256,
# Line 223  sub render_mem { Line 250  sub render_mem {
250    
251          $vram->display_format;          $vram->display_format;
252    
253          my $rect     = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );          my $rect     = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width, -height => $self->window_height );
254          my $rect_mem = SDL::Rect->new( -x => 256 * $self->scale, -y => 0, -width => 256, -height => 256 );          my $rect_mem = SDL::Rect->new( -x => $self->screen_width * $self->scale, -y => 0, -width => 256, -height => 256 );
255    
256          $vram->blit( $rect, $app, $rect_mem );          $vram->blit( $rect, $app, $rect_mem );
257    
# Line 245  Check SDL event loop if there are any pe Line 272  Check SDL event loop if there are any pe
272  =cut  =cut
273    
274  my $pending_key;  my $pending_key;
275    my $key_active;
276  my $run_for = 2000;  my $run_for = 2000;
277    
278  sub key_pressed {  sub key_pressed {
# Line 262  sub key_pressed { Line 290  sub key_pressed {
290                          if ( $state ) {                          if ( $state ) {
291                                  $pending_key = $key;                                  $pending_key = $key;
292                                  $self->key_down( $key );                                  $self->key_down( $key );
293                                    $key_active->{$key} = 1;
294                          } else {                          } else {
295                                  undef $pending_key;                                  undef $pending_key;
296                                  $self->key_up( $key );                                  $self->key_up( $key );
297                                    $key_active->{$key} = 0;
298                          }                          }
299                  }                  }
300                  return $pending_key;                  return $pending_key;
# Line 272  sub key_pressed { Line 302  sub key_pressed {
302    
303          my $type = $event->type();          my $type = $event->type();
304    
305          exit if ($type == SDL_QUIT);          exit if ($type == SDL::App::SDL_QUIT);
306    
307          my $k = $pending_key;          my $k = $pending_key;
308    
309          if ($type == SDL_KEYDOWN) {          if ($type == SDL::App::SDL_KEYDOWN) {
310                  $k = $event->key_name();                  $k = $event->key_name();
311                  if ( $k eq 'escape' ) {                  if ( $k eq 'escape' ) {
312                          $run_for = $self->cli;                          $run_for = $self->cli;
# Line 286  sub key_pressed { Line 316  sub key_pressed {
316                          warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";                          warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";
317                          $pending_key = $k;                          $pending_key = $k;
318                          $self->key_down( $k );                          $self->key_down( $k );
319                            $key_active->{$k} = 1;
320                          $self->record_session('key_pressed', { $k => 1 });                          $self->record_session('key_pressed', { $k => 1 });
321                  }                  }
322          } elsif ( $type == SDL_KEYUP ) {          } elsif ( $type == SDL::App::SDL_KEYUP ) {
323                  my $up = $event->key_name();                  my $up = $event->key_name();
324                  warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";                  warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
325                  $self->key_up( $up );                  $self->key_up( $up );
326                    $key_active->{$up} = 0;
327                  $self->record_session('key_pressed', { $up => 0 });                  $self->record_session('key_pressed', { $up => 0 });
328                  undef $pending_key;                  undef $pending_key;
329          }          }
# Line 301  sub key_pressed { Line 333  sub key_pressed {
333          return $pending_key;          return $pending_key;
334  }  }
335    
336    =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  =head2 loop  =head2 loop
359    
360  Implement CPU run for C<$run_run> cycles inside SDL event loop  Implement CPU run for C<$run_run> cycles inside SDL event loop
# Line 326  sub loop { Line 380  sub loop {
380          }          }
381  }  }
382    
383    =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    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  =head1 SEE ALSO  =head1 SEE ALSO
408    
409  L<Orao> is sample implementation using this module  L<Orao> is sample implementation using this module
Legend:
Removed from v.161  
changed lines
  Added in v.216
  ViewVC Help
Powered by ViewVC 1.1.26