/[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 98 - (hide annotations)
Thu Aug 2 16:01:16 2007 UTC (16 years, 7 months ago) by dpavlin
Original Path: M6502/Screen.pm
File size: 5907 byte(s)
non-working keyboard :-/
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 dpavlin 98 __PACKAGE__->mk_accessors(qw(app event));
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 dpavlin 98 $self->app( $app );
50    
51     my $event = SDL::Event->new();
52     $self->event( $event );
53    
54 dpavlin 29 warn "# created SDL::App\n";
55     }
56    
57     my $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
58     my $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 );
59    
60     my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 );
61     my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 );
62     my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff );
63    
64 dpavlin 76 my $rect_screen = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
65     my $rect_mem = SDL::Rect->new( -x => 256, -y => 0, -width => 256, -height => 256 );
66    
67 dpavlin 29 =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 vram
110    
111     Push byte to video memory and draw it
112    
113     $screen->vram( $offset, $byte );
114    
115     =cut
116    
117 dpavlin 37 my $_vram_counter;
118    
119 dpavlin 29 sub vram {
120     my ( $self, $offset, $byte ) = @_;
121     my $x = ( $offset % 32 ) << 3;
122     my $y = $offset >> 5;
123     my $mask = 1;
124 dpavlin 37 my $scale = $self->scale;
125 dpavlin 29
126 dpavlin 45 printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;
127 dpavlin 29
128     foreach ( 0 .. 7 ) {
129 dpavlin 37 my $on = $byte & $mask;
130     if ( $scale == 1 ) {
131     $app->pixel( $x + $_, $y, $on ? $white : $black );
132     } else {
133     $self->p($x + $_, $y, $on );
134     }
135 dpavlin 29 $mask = $mask << 1;
136     }
137 dpavlin 37
138     $app->sync if ( $_vram_counter++ % 10 == 0 );
139 dpavlin 29 }
140    
141 dpavlin 32 =head2 mmap_pixel
142    
143     Draw pixel in memory map
144    
145     $self->mmap_pixel( $addr, $r, $g, $b );
146    
147     =cut
148    
149     # keep accesses to memory
150     my $_mem_stat;
151    
152     sub mmap_pixel {
153     my ( $self, $addr, $r, $g, $b ) = @_;
154 dpavlin 33 return unless $self->show_mem && $self->app;
155 dpavlin 32
156 dpavlin 33 my ( $x, $y ) = $self->mem_xy( $addr );
157 dpavlin 41 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
158 dpavlin 32
159 dpavlin 33 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
160     $self->app->pixel( $x, $y, $col );
161 dpavlin 32
162     $_mem_stat++;
163     if ( $_mem_stat % 1000 == 0 ) {
164 dpavlin 33 $self->app->sync;
165 dpavlin 32 }
166     }
167    
168 dpavlin 33
169     =head2 sync
170    
171     $self->sync;
172    
173     =cut
174    
175     sub sync {
176     $app->sync;
177     }
178    
179 dpavlin 73 =head2 render
180    
181 dpavlin 76 Render one frame of video ram
182    
183 dpavlin 73 $self->render( @video_memory );
184    
185     =cut
186    
187     sub render {
188     my $self = shift;
189    
190     die "this function isn't supported if scale isn't 1" unless $self->scale == 1;
191    
192 dpavlin 75 my $pixels = pack("C*", @_);
193 dpavlin 73
194 dpavlin 75 my $vram = SDL::Surface->new(
195     -width => 256,
196     -height => 256,
197     -depth => 1, # 1 bit per pixel
198     -pitch => 32, # bytes per line
199     -from => $pixels,
200     );
201     $vram->set_colors( 0, $black, $white, $red );
202     $vram->display_format;
203 dpavlin 73
204 dpavlin 75 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
205 dpavlin 76 $vram->blit( $rect, $app, $rect_screen );
206 dpavlin 73
207     $app->sync;
208     }
209    
210 dpavlin 76 =head2 render_mem
211    
212     $self->render_mem( @ram );
213    
214     =cut
215    
216     sub render_mem {
217     my $self = shift;
218    
219     return unless $self->show_mem;
220    
221     my $pixels = pack("C*", @_);
222    
223     my $vram = SDL::Surface->new(
224     -width => 256,
225     -height => 256,
226     -depth => 8, # 1 bit per pixel
227     -pitch => 256, # bytes per line
228     -from => $pixels,
229     -Rmask => 0xffff00ff,
230     -Gmask => 0xffff00ff,
231     -Bmask => 0xffff00ff,
232     );
233    
234     $vram->display_format;
235    
236     my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
237     $vram->blit( $rect, $app, $rect_mem );
238    
239     $app->sync;
240     }
241    
242 dpavlin 98 =head2 key_pressed
243    
244     Check SDL event loop if there are any pending keys
245    
246     my $key = $self->key_pressed;
247    
248     if ( $self->key_pressed( 1 ) ) {
249     # just to check other events, don't process
250     # key
251     }
252    
253     =cut
254    
255     my $pending_key;
256     my $run_for = 2000;
257    
258     sub key_pressed {
259     my $self = shift;
260    
261     # don't take key, just pull event
262     my $just_checking = shift;
263    
264     if ( defined($pending_key) ) {
265     my $k = $pending_key;
266     undef $pending_key unless $just_checking;
267     return $k;
268     }
269    
270     my $event = $self->event || confess "no event?";
271    
272     $event->poll || return;
273    
274     my $type = $event->type();
275    
276     exit if ($type == SDL_QUIT);
277    
278     my $k;
279    
280     if ($type == SDL_KEYDOWN) {
281     $k = $event->key_name();
282     if ( $k eq 'escape' ) {
283     $run_for = $self->cli;
284     warn "will check event loop every $run_for cycles\n";
285     } else {
286     warn "SDL_KEYDOWN ($type) = '$k'\n";
287     $pending_key = $k if $just_checking;
288     }
289     } elsif ( $type == SDL_KEYUP ) {
290     my $up = $event->key_name();
291     warn "SDL_KEYUP ($type) = '$up'\n";
292     }
293    
294     return $k;
295     }
296    
297 dpavlin 96 =head2 loop
298    
299     Implement SDL event loop
300    
301     =cut
302    
303     sub loop {
304     my $self = shift;
305     my $event = SDL::Event->new();
306    
307    
308     MAIN_LOOP:
309     while ( 1 ) {
310 dpavlin 98 $self->key_pressed( 1 );
311 dpavlin 96 M6502::exec($run_for);
312     }
313     }
314    
315 dpavlin 55 =head1 SEE ALSO
316    
317     L<Orao> is sample implementation using this module
318    
319     =head1 AUTHOR
320    
321     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
322    
323     =head1 COPYRIGHT & LICENSE
324    
325     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
326    
327     This program is free software; you can redistribute it and/or modify it
328     under the same terms as Perl itself.
329    
330     =cut
331 dpavlin 32 1;

  ViewVC Help
Powered by ViewVC 1.1.26