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

Annotation of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26