package Screen;
# Dobrica Pavlinusic, <dpavlin@rot13.org> 07/30/07 17:58:55 CEST
use strict;
use warnings;
use SDL::App;
use SDL::Rect;
use SDL::Color;
use SDL::Constants;
use Carp qw/confess/;
use Data::Dump qw/dump/;
use Exporter 'import';
our @EXPORT = qw'$white $black @flip';
use base qw(Class::Accessor Prefs);
__PACKAGE__->mk_accessors(qw(app event screen_width screen_height window_width window_height));
=head1 NAME
Screen - simulated monochrome screen using SDL
=head1 Architecture dependent
You may override following methods if you want to implement keyboard on each
keypress event. Alternative is to use <read> hook and trap memory access.
=head2 screen_width
Width of emulated screen (256 by default)
=head2 screen_height
Height of emulated screen (256 by default)
=head2 key_down
$self->key_down( 'a' );
=cut
sub key_down {}
=head2 key_up
$self->key_up( 'a' );
=cut
sub key_up {}
=head1 Architecture independent
You don't need to override any of following function in your architecture,
but you might want to call them.
=head2 open_screen
Open simulated screen
=cut
our $app;
sub open_screen {
my $self = shift;
$self->prefs;
if ( ! $self->scale ) {
$self->scale( 1 );
warn "using default unscaled display\n";
}
$self->screen_width( 256 ) unless defined $self->screen_width;
$self->screen_height( 256 ) unless defined $self->screen_height;
my $w = $self->screen_width * $self->scale + ( $self->show_mem ? 256 : 0 );
$self->window_width( $w );
my $h = $self->screen_height;
# expand screen size to show whole 64k 256*256 memory map
$h = 256 if $self->show_mem && $h < 256;
$h *= $self->scale;
$self->window_height( $h );
$app = SDL::App->new(
-width => $w,
-height => $h,
-depth => 16,
-flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
);
#$app->grab_input( SDL_GRAB_QUERY );
$app->grab_input( SDL_GRAB_OFF );
$app->title( ref($self) );
$self->app( $app );
my $event = SDL::Event->new();
$self->event( $event );
warn "# created SDL::App with screen ", $self->screen_width, "x", $self->screen_height, " in window ",
$self->window_width, "x", $self->window_height, "\n";
}
our $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
our $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
=head2 mem_xy
Helper to return x and y coordinates in memory map
my ( $x,$y ) = $screen->mem_xy( $address );
=cut
sub mem_xy {
my $self = shift;
my $offset = shift;
my $x = $offset & 0xff;
$x += $self->screen_width * $self->scale;
my $y = $offset >> 8;
return ($x,$y);
}
=head2 mmap_pixel
Draw pixel in memory map
$self->mmap_pixel( $addr, $r, $g, $b );
=cut
# keep accesses to memory
my $_mem_stat;
sub mmap_pixel {
my ( $self, $addr, $r, $g, $b ) = @_;
return unless $self->show_mem && $self->app;
my ( $x, $y ) = $self->mem_xy( $addr );
warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
$self->app->pixel( $x, $y, $col );
$_mem_stat++;
if ( $_mem_stat % 1000 == 0 ) {
$self->app->sync;
}
}
=head2 sync
$self->sync;
=cut
sub sync {
$app->sync;
}
=head2 render_vram
Render one frame of video ram
$self->render_vram;
=cut
sub render_vram {
my $self = shift;
confess "please implement $self::render_vram";
}
=head2 render_frame
Render one frame of video ram
$self->render_frame( $vram_sdl_surface );
=cut
sub render_frame {
my $self = shift;
my $vram = shift;
confess "need SDL::Surface as argument" unless ref($vram) eq 'SDL::Surface';
$vram->display_format;
my $scale = $self->scale || confess "no scale?";
my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width * $scale, -height => $self->screen_height * $scale );
my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width * $scale, -height => $self->screen_height * $scale );
if ( $scale > 1 ) {
use SDL::Tool::Graphic;
# last parametar is anti-alias
my $zoomed = SDL::Tool::Graphic->zoom( $vram, $self->scale, $self->scale, 1 );
$zoomed->blit( $rect, $app, $rect_screen );
} else {
$vram->blit( $rect, $app, $rect_screen );
}
$app->sync;
}
=head2 render_mem
$self->render_mem( @mem );
$self->render_mem( $memory_bytes );
=cut
sub render_mem {
my $self = shift;
return unless $self->show_mem;
my $pixels;
if ( defined $# ) {
$pixels = pack("C*", @_);
} else {
$pixels = shift;
}
my $vram = SDL::Surface->new(
-width => 256,
-height => 256,
-depth => 8, # 1 bit per pixel
-pitch => 256, # bytes per line
-from => $pixels,
-Rmask => 0xffff00ff,
-Gmask => 0xffff00ff,
-Bmask => 0xffff00ff,
);
$vram->display_format;
my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => $self->screen_width, -height => $self->window_height );
my $rect_mem = SDL::Rect->new( -x => $self->screen_width * $self->scale, -y => 0, -width => 256, -height => 256 );
$vram->blit( $rect, $app, $rect_mem );
$app->sync;
}
=head2 key_pressed
Check SDL event loop if there are any pending keys
my $key = $self->key_pressed;
if ( $self->key_pressed( 1 ) ) {
# just to check other events, don't process
# key
}
=cut
my $pending_key;
my $key_active;
my $run_for = 2000;
sub key_pressed {
my $self = shift;
# don't take key, just pull event
my $just_checking = shift || 0;
my $event = $self->event || confess "no event?";
if ( ! $event->poll ) {
return $pending_key unless $self->can('session_event');
if ( my $h = $self->session_event('key_pressed') ) {
my ( $key, $state ) = %$h;
if ( $state ) {
$pending_key = $key;
$self->key_down( $key );
$key_active->{$key} = 1;
} else {
undef $pending_key;
$self->key_up( $key );
$key_active->{$key} = 0;
}
}
return $pending_key;
}
my $type = $event->type();
exit if ($type == SDL_QUIT);
my $k = $pending_key;
if ($type == SDL_KEYDOWN) {
$k = $event->key_name();
if ( $k eq 'escape' ) {
$run_for = $self->cli;
warn "will check event loop every $run_for cycles\n";
$pending_key = '~';
} else {
warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";
$pending_key = $k;
$self->key_down( $k );
$key_active->{$k} = 1;
$self->record_session('key_pressed', { $k => 1 });
}
} elsif ( $type == SDL_KEYUP ) {
my $up = $event->key_name();
warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
$self->key_up( $up );
$key_active->{$up} = 0;
$self->record_session('key_pressed', { $up => 0 });
undef $pending_key;
}
warn "key_pressed = $pending_key\n" if ( $pending_key );
return $pending_key;
}
=head2 key_active
Is key currently pressed on keyboard or in session?
$self->key_active( 'left shift', 'right shift', 'a' );
=cut
sub key_active {
my $self = shift;
my @keys = @_;
confess "Regexp is no longer supported" if ref($_[0]) eq 'Regexp';
my $active = 0;
foreach my $key ( @keys ) {
$active++ if $key_active->{$key};
}
warn "## key_active(",dump(@keys),") = $active\n" if $active;
return $active;
}
=head2 loop
Implement CPU run for C<$run_run> cycles inside SDL event loop
$self->loop( sub {
my $run_for = shift;
CPU::exec( $run_for );
$self->render_vram;
} );
=cut
sub loop {
my $self = shift;
my $exec = shift;
confess "need coderef as argument" unless ref($exec) eq 'CODE';
my $event = SDL::Event->new();
while ( 1 ) {
$self->key_pressed( 1 );
$exec->($run_for);
}
}
=head2 @flip
Exported helper array used to flip bytes (from character roms for example)
my $flipped = $flip[ $byte ];
=cut
our @flip;
foreach my $i ( 0 .. 255 ) {
my $t = 0;
$i & 0b00000001 and $t = $t | 0b10000000;
$i & 0b00000010 and $t = $t | 0b01000000;
$i & 0b00000100 and $t = $t | 0b00100000;
$i & 0b00001000 and $t = $t | 0b00010000;
$i & 0b00010000 and $t = $t | 0b00001000;
$i & 0b00100000 and $t = $t | 0b00000100;
$i & 0b01000000 and $t = $t | 0b00000010;
$i & 0b10000000 and $t = $t | 0b00000001;
#warn "$i = $t\n";
$flip[$i] = $t;
}
=head1 SEE ALSO
L<Orao> is sample implementation using this module
=head1 AUTHOR
Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
=head1 COPYRIGHT & LICENSE
Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
RSS Feed