viewvc.cgi/VRac/Screen.pm

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 base qw(Class::Accessor Prefs);
__PACKAGE__->mk_accessors(qw(app));

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

        warn "# created SDL::App\n";
        $self->app( $app );
}

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

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

Push byte to video memory and draw it

  $screen->vram( $offset, $byte );

=cut

my $_vram_counter;

sub vram {
        my ( $self, $offset, $byte ) = @_;
        my $x = ( $offset % 32 ) << 3;
        my $y = $offset >> 5;
        my $mask = 1;
        my $scale = $self->scale;

        printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;

        foreach ( 0 .. 7 ) {
                my $on = $byte & $mask;
                if ( $scale == 1 ) {
                        $app->pixel( $x + $_, $y, $on ? $white : $black );
                } else {
                        $self->p($x + $_, $y, $on );
                }
                $mask = $mask << 1;
        }

        $app->sync if ( $_vram_counter++ % 10 == 0 );
}

=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

  $self->render( @video_memory );

=cut

sub render {
        my $self = shift;

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

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

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

        $app->sync;
}

=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;
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	56	use base qw(Class::Accessor Prefs);
17			__PACKAGE__->mk_accessors(qw(app));
18	dpavlin	29
19	dpavlin	55	=head1 NAME
20
21			Screen - simulated 256*256 pixels monochrome screen using SDL
22
23	dpavlin	30	=head2 open_screen
24	dpavlin	29
25			Open simulated screen
26
27			=cut
28
29			our $app;
30
31	dpavlin	30	sub open_screen {
32	dpavlin	29	my $self = shift;
33	dpavlin	31
34	dpavlin	56	$self->prefs;
35
36	dpavlin	31	if ( ! $self->scale ) {
37			$self->scale( 1 );
38			warn "using default unscaled display\n";
39			}
40
41	dpavlin	29	$app = SDL::App->new(
42			-width => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
43			-height => 256 * $self->scale,
44			-depth => 16,
45			);
46	dpavlin	75	#$app->grab_input( SDL_GRAB_QUERY );
47			$app->grab_input( SDL_GRAB_OFF );
48	dpavlin	29
49			warn "# created SDL::App\n";
50	dpavlin	33	$self->app( $app );
51	dpavlin	29	}
52
53			my $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
54			my $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
55
56			my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
57			my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
58			my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
59
60			=head2 p
61
62			$screen->p( $x, $y, 1 );
63
64			=cut
65
66			sub p {
67			my $self = shift;
68
69			my ($x,$y,$w) = (@_);
70
71			warn "p($x,$y,$w)\n" if $self->debug;
72
73			my $scale = $self->scale;
74			my $rect = SDL::Rect->new(
75			-height => $scale,
76			-width => $scale,
77			-x => $x * $scale,
78			-y => $y * $scale,
79			);
80
81			$app->fill( $rect, $w ? $white : $black );
82			$app->update( $rect );
83			}
84
85			=head2 mem_xy
86
87			Helper to return x and y coordinates in memory map
88
89			my ( $x,$y ) = $screen->mem_xy( $address );
90
91			=cut
92
93			sub mem_xy {
94			my $self = shift;
95			my $offset = shift;
96			my $x = $offset & 0xff;
97			$x += 256 * $self->scale;
98			my $y = $offset >> 8;
99			return ($x,$y);
100			}
101
102			=head2 vram
103
104			Push byte to video memory and draw it
105
106			$screen->vram( $offset, $byte );
107
108			=cut
109
110	dpavlin	37	my $_vram_counter;
111
112	dpavlin	29	sub vram {
113			my ( $self, $offset, $byte ) = @_;
114			my $x = ( $offset % 32 ) << 3;
115			my $y = $offset >> 5;
116			my $mask = 1;
117	dpavlin	37	my $scale = $self->scale;
118	dpavlin	29
119	dpavlin	45	printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;
120	dpavlin	29
121			foreach ( 0 .. 7 ) {
122	dpavlin	37	my $on = $byte & $mask;
123			if ( $scale == 1 ) {
124			$app->pixel( $x + $_, $y, $on ? $white : $black );
125			} else {
126			$self->p($x + $_, $y, $on );
127			}
128	dpavlin	29	$mask = $mask << 1;
129			}
130	dpavlin	37
131			$app->sync if ( $_vram_counter++ % 10 == 0 );
132	dpavlin	29	}
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	73	=head2 render
173
174			$self->render( @video_memory );
175
176			=cut
177
178			sub render {
179			my $self = shift;
180
181			die "this function isn't supported if scale isn't 1" unless $self->scale == 1;
182
183	dpavlin	75	my $pixels = pack("C*", @_);
184	dpavlin	73
185	dpavlin	75	my $vram = SDL::Surface->new(
186			-width => 256,
187			-height => 256,
188			-depth => 1, # 1 bit per pixel
189			-pitch => 32, # bytes per line
190			-from => $pixels,
191			);
192			$vram->set_colors( 0, $black, $white, $red );
193			$vram->display_format;
194	dpavlin	73
195	dpavlin	75	my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
196			$vram->blit( $rect, $app, $rect );
197	dpavlin	73
198			$app->sync;
199			}
200
201	dpavlin	55	=head1 SEE ALSO
202
203			L<Orao> is sample implementation using this module
204
205			=head1 AUTHOR
206
207			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
208
209			=head1 COPYRIGHT & LICENSE
210
211			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
212
213			This program is free software; you can redistribute it and/or modify it
214			under the same terms as Perl itself.
215
216			=cut
217	dpavlin	32	1;