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

Contents of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 124 - (show annotations)
Sat Aug 4 14:13:28 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 6500 byte(s)
re-organize file patch to new VRac layout to ease re-use of code
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 use M6502 qw'@mem';
16
17 use base qw(Class::Accessor Prefs);
18 __PACKAGE__->mk_accessors(qw(app event));
19
20 =head1 NAME
21
22 Screen - simulated 256*256 pixels monochrome screen using SDL
23
24 =head2 open_screen
25
26 Open simulated screen
27
28 =cut
29
30 our $app;
31
32 sub open_screen {
33 my $self = shift;
34
35 $self->prefs;
36
37 if ( ! $self->scale ) {
38 $self->scale( 1 );
39 warn "using default unscaled display\n";
40 }
41
42 $app = SDL::App->new(
43 -width => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
44 -height => 256 * $self->scale,
45 -depth => 16,
46 );
47 #$app->grab_input( SDL_GRAB_QUERY );
48 $app->grab_input( SDL_GRAB_OFF );
49
50 $self->app( $app );
51
52 my $event = SDL::Event->new();
53 $self->event( $event );
54
55 warn "# created SDL::App\n";
56 }
57
58 my $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
59 my $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
60
61 my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
62 my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
63 my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
64
65 my $rect_mem = SDL::Rect->new( -x => 256, -y => 0, -width => 256, -height => 256 );
66
67 =head2 p
68
69 $screen->p( $x, $y, 1 );
70
71 =cut
72
73 sub p {
74 my $self = shift;
75
76 my ($x,$y,$w) = (@_);
77
78 warn "p($x,$y,$w)\n" if $self->debug;
79
80 my $scale = $self->scale;
81 my $rect = SDL::Rect->new(
82 -height => $scale,
83 -width => $scale,
84 -x => $x * $scale,
85 -y => $y * $scale,
86 );
87
88 $app->fill( $rect, $w ? $white : $black );
89 $app->update( $rect );
90 }
91
92 =head2 mem_xy
93
94 Helper to return x and y coordinates in memory map
95
96 my ( $x,$y ) = $screen->mem_xy( $address );
97
98 =cut
99
100 sub mem_xy {
101 my $self = shift;
102 my $offset = shift;
103 my $x = $offset & 0xff;
104 $x += 256 * $self->scale;
105 my $y = $offset >> 8;
106 return ($x,$y);
107 }
108
109 =head2 mmap_pixel
110
111 Draw pixel in memory map
112
113 $self->mmap_pixel( $addr, $r, $g, $b );
114
115 =cut
116
117 # keep accesses to memory
118 my $_mem_stat;
119
120 sub mmap_pixel {
121 my ( $self, $addr, $r, $g, $b ) = @_;
122 return unless $self->show_mem && $self->app;
123
124 my ( $x, $y ) = $self->mem_xy( $addr );
125 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
126
127 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
128 $self->app->pixel( $x, $y, $col );
129
130 $_mem_stat++;
131 if ( $_mem_stat % 1000 == 0 ) {
132 $self->app->sync;
133 }
134 }
135
136
137 =head2 sync
138
139 $self->sync;
140
141 =cut
142
143 sub sync {
144 $app->sync;
145 }
146
147 =head2 render_vram
148
149 Render one frame of video ram
150
151 $self->render_vram( @video_memory );
152
153 =cut
154
155 my @flip;
156
157 foreach my $i ( 0 .. 255 ) {
158 my $t = 0;
159 $i & 0b00000001 and $t = $t | 0b10000000;
160 $i & 0b00000010 and $t = $t | 0b01000000;
161 $i & 0b00000100 and $t = $t | 0b00100000;
162 $i & 0b00001000 and $t = $t | 0b00010000;
163 $i & 0b00010000 and $t = $t | 0b00001000;
164 $i & 0b00100000 and $t = $t | 0b00000100;
165 $i & 0b01000000 and $t = $t | 0b00000010;
166 $i & 0b10000000 and $t = $t | 0b00000001;
167 #warn "$i = $t\n";
168 $flip[$i] = $t;
169 }
170
171
172 sub render_vram {
173 my $self = shift;
174
175 return unless $self->booted;
176
177 confess "no data?" unless (@_);
178 confess "screen size not 256*256/8 but ",($#_+1) unless (($#_+1) == (256*256/8));
179
180 my $pixels = pack("C*", map { $flip[$_] } @_);
181
182 my $vram = SDL::Surface->new(
183 -width => 256,
184 -height => 256,
185 -depth => 1, # 1 bit per pixel
186 -pitch => 32, # bytes per line
187 -from => $pixels,
188 );
189 $vram->set_colors( 0, $black, $white, $red );
190 $vram->display_format;
191
192 my $scale = $self->scale;
193
194 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );
195 my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256 * $scale, -height => 256 * $scale );
196
197 if ( $scale > 1 ) {
198 use SDL::Tool::Graphic;
199 # last parametar is anti-alias
200 my $zoomed = SDL::Tool::Graphic->zoom( $vram, $self->scale, $self->scale, 1 );
201 $zoomed->blit( $rect, $app, $rect_screen );
202 } else {
203 $vram->blit( $rect, $app, $rect_screen );
204 }
205
206 $app->sync;
207 }
208
209 =head2 render_mem
210
211 $self->render_mem( @ram );
212
213 =cut
214
215 sub render_mem {
216 my $self = shift;
217
218 return unless $self->show_mem;
219
220 my $pixels = pack("C*", @_);
221
222 my $vram = SDL::Surface->new(
223 -width => 256,
224 -height => 256,
225 -depth => 8, # 1 bit per pixel
226 -pitch => 256, # bytes per line
227 -from => $pixels,
228 -Rmask => 0xffff00ff,
229 -Gmask => 0xffff00ff,
230 -Bmask => 0xffff00ff,
231 );
232
233 $vram->display_format;
234
235 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
236 $vram->blit( $rect, $app, $rect_mem );
237
238 $app->sync;
239 }
240
241 =head2 key_pressed
242
243 Check SDL event loop if there are any pending keys
244
245 my $key = $self->key_pressed;
246
247 if ( $self->key_pressed( 1 ) ) {
248 # just to check other events, don't process
249 # key
250 }
251
252 =cut
253
254 my $pending_key;
255 my $run_for = 2000;
256
257 my $key_down;
258
259 sub key_down {
260 my $self = shift;
261 my $key = shift;
262 warn "key_down($key) = ",$key_down->{$key}, "\n" if $self->debug;
263 return $key_down->{$key};
264 }
265
266 sub key_pressed {
267 my $self = shift;
268
269 # don't take key, just pull event
270 my $just_checking = shift || 0;
271
272 my $event = $self->event || confess "no event?";
273
274 $event->poll || return $pending_key;
275
276 my $type = $event->type();
277
278 exit if ($type == SDL_QUIT);
279
280 my $k = $pending_key;
281
282 if ($type == SDL_KEYDOWN) {
283 $k = $event->key_name();
284 $key_down->{$k}++;
285 if ( $k eq 'escape' ) {
286 $run_for = $self->cli;
287 warn "will check event loop every $run_for cycles\n";
288 $pending_key = '~';
289 } else {
290 warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";
291 $pending_key = $k;
292 }
293 } elsif ( $type == SDL_KEYUP ) {
294 my $up = $event->key_name();
295 $key_down->{$up} = 0;
296 warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
297 undef $pending_key;
298 }
299
300 warn "key_pressed = $pending_key\n" if $pending_key;
301
302 return $pending_key;
303 }
304
305 =head2 loop
306
307 Implement SDL event loop
308
309 =cut
310
311 sub loop {
312 my $self = shift;
313 my $event = SDL::Event->new();
314
315
316 MAIN_LOOP:
317 while ( 1 ) {
318 $self->key_pressed( 1 );
319 M6502::exec($run_for);
320 $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
321 }
322 }
323
324 =head1 SEE ALSO
325
326 L<Orao> is sample implementation using this module
327
328 =head1 AUTHOR
329
330 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
331
332 =head1 COPYRIGHT & LICENSE
333
334 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
335
336 This program is free software; you can redistribute it and/or modify it
337 under the same terms as Perl itself.
338
339 =cut
340 1;

  ViewVC Help
Powered by ViewVC 1.1.26