/[VRac]/M6502/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

Contents of /M6502/Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 96 - (show annotations)
Thu Aug 2 13:58:26 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 5091 byte(s)
added SDL event loop around CPU emulation
1 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 use SDL::Constants;
12
13 use Carp qw/confess/;
14 use Data::Dump qw/dump/;
15
16 use base qw(Class::Accessor Prefs);
17 __PACKAGE__->mk_accessors(qw(app));
18
19 =head1 NAME
20
21 Screen - simulated 256*256 pixels monochrome screen using SDL
22
23 =head2 open_screen
24
25 Open simulated screen
26
27 =cut
28
29 our $app;
30
31 sub open_screen {
32 my $self = shift;
33
34 $self->prefs;
35
36 if ( ! $self->scale ) {
37 $self->scale( 1 );
38 warn "using default unscaled display\n";
39 }
40
41 $app = SDL::App->new(
42 -width => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
43 -height => 256 * $self->scale,
44 -depth => 16,
45 );
46 #$app->grab_input( SDL_GRAB_QUERY );
47 $app->grab_input( SDL_GRAB_OFF );
48
49 warn "# created SDL::App\n";
50 $self->app( $app );
51 }
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 my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
61 my $rect_mem = SDL::Rect->new( -x => 256, -y => 0, -width => 256, -height => 256 );
62
63 =head2 p
64
65 $screen->p( $x, $y, 1 );
66
67 =cut
68
69 sub p {
70 my $self = shift;
71
72 my ($x,$y,$w) = (@_);
73
74 warn "p($x,$y,$w)\n" if $self->debug;
75
76 my $scale = $self->scale;
77 my $rect = SDL::Rect->new(
78 -height => $scale,
79 -width => $scale,
80 -x => $x * $scale,
81 -y => $y * $scale,
82 );
83
84 $app->fill( $rect, $w ? $white : $black );
85 $app->update( $rect );
86 }
87
88 =head2 mem_xy
89
90 Helper to return x and y coordinates in memory map
91
92 my ( $x,$y ) = $screen->mem_xy( $address );
93
94 =cut
95
96 sub mem_xy {
97 my $self = shift;
98 my $offset = shift;
99 my $x = $offset & 0xff;
100 $x += 256 * $self->scale;
101 my $y = $offset >> 8;
102 return ($x,$y);
103 }
104
105 =head2 vram
106
107 Push byte to video memory and draw it
108
109 $screen->vram( $offset, $byte );
110
111 =cut
112
113 my $_vram_counter;
114
115 sub vram {
116 my ( $self, $offset, $byte ) = @_;
117 my $x = ( $offset % 32 ) << 3;
118 my $y = $offset >> 5;
119 my $mask = 1;
120 my $scale = $self->scale;
121
122 printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;
123
124 foreach ( 0 .. 7 ) {
125 my $on = $byte & $mask;
126 if ( $scale == 1 ) {
127 $app->pixel( $x + $_, $y, $on ? $white : $black );
128 } else {
129 $self->p($x + $_, $y, $on );
130 }
131 $mask = $mask << 1;
132 }
133
134 $app->sync if ( $_vram_counter++ % 10 == 0 );
135 }
136
137 =head2 mmap_pixel
138
139 Draw pixel in memory map
140
141 $self->mmap_pixel( $addr, $r, $g, $b );
142
143 =cut
144
145 # keep accesses to memory
146 my $_mem_stat;
147
148 sub mmap_pixel {
149 my ( $self, $addr, $r, $g, $b ) = @_;
150 return unless $self->show_mem && $self->app;
151
152 my ( $x, $y ) = $self->mem_xy( $addr );
153 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
154
155 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
156 $self->app->pixel( $x, $y, $col );
157
158 $_mem_stat++;
159 if ( $_mem_stat % 1000 == 0 ) {
160 $self->app->sync;
161 }
162 }
163
164
165 =head2 sync
166
167 $self->sync;
168
169 =cut
170
171 sub sync {
172 $app->sync;
173 }
174
175 =head2 render
176
177 Render one frame of video ram
178
179 $self->render( @video_memory );
180
181 =cut
182
183 sub render {
184 my $self = shift;
185
186 die "this function isn't supported if scale isn't 1" unless $self->scale == 1;
187
188 my $pixels = pack("C*", @_);
189
190 my $vram = SDL::Surface->new(
191 -width => 256,
192 -height => 256,
193 -depth => 1, # 1 bit per pixel
194 -pitch => 32, # bytes per line
195 -from => $pixels,
196 );
197 $vram->set_colors( 0, $black, $white, $red );
198 $vram->display_format;
199
200 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
201 $vram->blit( $rect, $app, $rect_screen );
202
203 $app->sync;
204 }
205
206 =head2 render_mem
207
208 $self->render_mem( @ram );
209
210 =cut
211
212 sub render_mem {
213 my $self = shift;
214
215 return unless $self->show_mem;
216
217 my $pixels = pack("C*", @_);
218
219 my $vram = SDL::Surface->new(
220 -width => 256,
221 -height => 256,
222 -depth => 8, # 1 bit per pixel
223 -pitch => 256, # bytes per line
224 -from => $pixels,
225 -Rmask => 0xffff00ff,
226 -Gmask => 0xffff00ff,
227 -Bmask => 0xffff00ff,
228 );
229
230 $vram->display_format;
231
232 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
233 $vram->blit( $rect, $app, $rect_mem );
234
235 $app->sync;
236 }
237
238 =head2 loop
239
240 Implement SDL event loop
241
242 =cut
243
244 sub loop {
245 my $self = shift;
246 my $event = SDL::Event->new();
247
248 my $run_for = 2000;
249
250 MAIN_LOOP:
251 while ( 1 ) {
252 while ($event->poll) {
253 my $type = $event->type();
254
255 last MAIN_LOOP if ($type == SDL_QUIT);
256 last MAIN_LOOP if ($type == SDL_KEYDOWN && $event->key_name() eq 'escape');
257
258 if ($type == SDL_KEYDOWN) {
259 $run_for = $self->cli;
260 }
261 }
262 M6502::exec($run_for);
263 }
264 }
265
266 =head1 SEE ALSO
267
268 L<Orao> is sample implementation using this module
269
270 =head1 AUTHOR
271
272 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
273
274 =head1 COPYRIGHT & LICENSE
275
276 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
277
278 This program is free software; you can redistribute it and/or modify it
279 under the same terms as Perl itself.
280
281 =cut
282 1;

  ViewVC Help
Powered by ViewVC 1.1.26