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 M6502 qw'@mem';

use base qw(Class::Accessor Prefs);
__PACKAGE__->mk_accessors(qw(app event));

=head1 NAME

Screen - simulated 256*256 pixels monochrome screen using SDL

=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";
	}

	$app = SDL::App->new(
		-width  => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
		-height => 256 * $self->scale,
		-depth  => 16,
	);
	#$app->grab_input( SDL_GRAB_QUERY );
	$app->grab_input( SDL_GRAB_OFF );

	$self->app( $app );

	my $event = SDL::Event->new();
	$self->event( $event );

	warn "# created SDL::App\n";
}

my $white	= SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
my $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 );

my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
my $rect_mem = SDL::Rect->new( -x => 256, -y => 0, -width => 256, -height => 256 );

=head2 p

 $screen->p( $x, $y, 1 );

=cut

sub p {
	my $self = shift;

	my ($x,$y,$w) = (@_);

	warn "p($x,$y,$w)\n" if $self->debug;

	my $scale = $self->scale;
	my $rect = SDL::Rect->new(
		-height => $scale,
		-width  => $scale,
		-x      => $x * $scale,
		-y      => $y * $scale,
	);

	$app->fill( $rect, $w ? $white : $black );
	$app->update( $rect );
}

=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 += 256 * $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( @video_memory );

=cut

my @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;
}


sub render_vram {
	my $self = shift;

	return unless $self->booted;

	die "this function isn't supported if scale isn't 1" unless $self->scale == 1;

	confess "no data?" unless (@_);
	confess "screen size not 256*256/8 but ",($#_+1) unless (($#_+1) == (256*256/8));


	my $pixels = pack("C*", map { $flip[$_] } @_);

	my $vram = SDL::Surface->new(
		-width => 256,
		-height => 256,
		-depth => 1,	# 1 bit per pixel
		-pitch => 32,	# bytes per line
		-from => $pixels,
	);
	$vram->set_colors( 0, $black, $white, $red );
	$vram->display_format;

	my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
	$vram->blit( $rect, $app, $rect_screen );

	$app->sync;
}

=head2 render_mem

  $self->render_mem( @ram );

=cut

sub render_mem {
	my $self = shift;

	return unless $self->show_mem;

	my $pixels = pack("C*", @_);

	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 => 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 $run_for = 2000;

my $key_down;

sub key_down {
	my $self = shift;
	my $key = shift;
	warn "key_down($key) = ",$key_down->{$key}, "\n" if $self->debug;
	return $key_down->{$key};
}

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?";

	$event->poll || return $pending_key;

	my $type = $event->type();

	exit if ($type == SDL_QUIT);

	my $k = $pending_key;

	if ($type == SDL_KEYDOWN) {
		$k = $event->key_name();
		$key_down->{$k}++;
		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;
		}
	} elsif ( $type == SDL_KEYUP ) {
		my $up = $event->key_name();
		$key_down->{$up} = 0;
		warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
		undef $pending_key;
	}

	warn "key_pressed = $pending_key\n" if $pending_key;

	return $pending_key;
}

=head2 loop

Implement SDL event loop

=cut

sub loop {
	my $self = shift;
	my $event = SDL::Event->new();


	MAIN_LOOP:
	while ( 1 ) {
		$self->key_pressed( 1 );
		M6502::exec($run_for);
		$self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
	}
}

=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;