/[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 152 - (show annotations)
Sun Aug 5 15:24:22 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 6279 byte(s)
track key pressed so that shift now works from session files
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 Exporter 'import';
17 our @EXPORT = qw'$white $black';
18
19 use base qw(Class::Accessor Prefs);
20 __PACKAGE__->mk_accessors(qw(app event));
21
22 =head1 NAME
23
24 Screen - simulated 256*256 pixels monochrome screen using SDL
25
26 =head2 open_screen
27
28 Open simulated screen
29
30 =cut
31
32 our $app;
33
34 sub open_screen {
35 my $self = shift;
36
37 $self->prefs;
38
39 if ( ! $self->scale ) {
40 $self->scale( 1 );
41 warn "using default unscaled display\n";
42 }
43
44 $app = SDL::App->new(
45 -width => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
46 -height => 256 * $self->scale,
47 -depth => 16,
48 -flags=>SDL_DOUBLEBUF | SDL_HWSURFACE | SDL_HWACCEL,
49 );
50 #$app->grab_input( SDL_GRAB_QUERY );
51 $app->grab_input( SDL_GRAB_OFF );
52 $app->title( ref($self) . ' ' . $self::VERSION );
53
54 $self->app( $app );
55
56 my $event = SDL::Event->new();
57 $self->event( $event );
58
59 warn "# created SDL::App\n";
60 }
61
62 our $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
63 our $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
64
65 my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
66 my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
67 my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
68
69 =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 =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 return unless $self->show_mem && $self->app;
100
101 my ( $x, $y ) = $self->mem_xy( $addr );
102 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
103
104 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
105 $self->app->pixel( $x, $y, $col );
106
107 $_mem_stat++;
108 if ( $_mem_stat % 1000 == 0 ) {
109 $self->app->sync;
110 }
111 }
112
113
114 =head2 sync
115
116 $self->sync;
117
118 =cut
119
120 sub sync {
121 $app->sync;
122 }
123
124 =head2 render_vram
125
126 Render one frame of video ram
127
128 $self->render_vram;
129
130 =cut
131
132 sub render_vram {
133 my $self = shift;
134
135 confess "please implement $self::render_vram";
136 }
137
138
139 =head2 render_frame
140
141 Render one frame of video ram
142
143 $self->render_frame( $vram_sdl_surface );
144
145 =cut
146
147 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 $vram->display_format;
154
155 my $scale = $self->scale || confess "no scale?";
156
157 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 $app->sync;
170 }
171
172
173 =head2 render_mem
174
175 $self->render_mem( @mem );
176
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 my $rect_mem = SDL::Rect->new( -x => 256 * $self->scale, -y => 0, -width => 256, -height => 256 );
201
202 $vram->blit( $rect, $app, $rect_mem );
203
204 $app->sync;
205 }
206
207 =head2 key_pressed
208
209 Check SDL event loop if there are any pending keys
210
211 my $key = $self->key_pressed;
212
213 if ( $self->key_pressed( 1 ) ) {
214 # just to check other events, don't process
215 # key
216 }
217
218 =cut
219
220 my $pending_key;
221 my $run_for = 2000;
222
223 my $key_down;
224
225 sub key_down {
226 my $self = shift;
227 my $key = shift;
228 warn "key_down($key) = ",$key_down->{$key}, "\n" if $self->debug;
229 return $key_down->{$key};
230 }
231
232 sub key_pressed {
233 my $self = shift;
234
235 # don't take key, just pull event
236 my $just_checking = shift || 0;
237
238 my $event = $self->event || confess "no event?";
239
240 if ( ! $event->poll ) {
241 if ( my $h = $self->session_event('key_pressed') ) {
242 my ( $key, $state ) = %$h;
243 if ( $state ) {
244 $pending_key = $key;
245 $key_down->{$key}++;
246 } else {
247 undef $pending_key;
248 $key_down->{$key} = 0;
249 }
250 }
251 return $pending_key;
252 }
253
254 my $type = $event->type();
255
256 exit if ($type == SDL_QUIT);
257
258 my $k = $pending_key;
259
260 if ($type == SDL_KEYDOWN) {
261 $k = $event->key_name();
262 $key_down->{$k}++;
263 if ( $k eq 'escape' ) {
264 $run_for = $self->cli;
265 warn "will check event loop every $run_for cycles\n";
266 $pending_key = '~';
267 } else {
268 warn "SDL_KEYDOWN ($type) = '$k'", $just_checking ? ' fake' : '', "\n";
269 $pending_key = $k;
270 $self->record_session('key_pressed', { $k => 1 });
271 }
272 } elsif ( $type == SDL_KEYUP ) {
273 my $up = $event->key_name();
274 warn "SDL_KEYUP ($type) = '$up'", $just_checking ? ' fake' : '', "\n";
275 $self->record_session('key_pressed', { $up => 0 });
276 $key_down->{$up} = 0;
277 undef $pending_key;
278 }
279
280 warn "key_pressed = $pending_key\n" if ( $pending_key );
281
282 return $pending_key;
283 }
284
285 =head2 loop
286
287 Implement CPU run for C<$run_run> cycles inside SDL event loop
288
289 $self->loop( sub {
290 my $run_for = shift;
291 CPU::exec( $run_for );
292 $self->render_vram;
293 } );
294
295 =cut
296
297 sub loop {
298 my $self = shift;
299 my $exec = shift;
300
301 confess "need coderef as argument" unless ref($exec) eq 'CODE';
302 my $event = SDL::Event->new();
303
304 while ( 1 ) {
305 $self->key_pressed( 1 );
306 $exec->($run_for);
307 }
308 }
309
310 =head1 SEE ALSO
311
312 L<Orao> is sample implementation using this module
313
314 =head1 AUTHOR
315
316 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
317
318 =head1 COPYRIGHT & LICENSE
319
320 Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
321
322 This program is free software; you can redistribute it and/or modify it
323 under the same terms as Perl itself.
324
325 =cut
326
327 1;

  ViewVC Help
Powered by ViewVC 1.1.26