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

Annotation of /M6502/Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 76 - (hide annotations)
Wed Aug 1 12:57:15 2007 UTC (16 years, 8 months ago) by dpavlin
File size: 4658 byte(s)
and in the same spirit, render memory map super-fast using SDL (and in the
process, make it white :-)
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     __PACKAGE__->mk_accessors(qw(app));
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     warn "# created SDL::App\n";
50 dpavlin 33 $self->app( $app );
51 dpavlin 29 }
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 dpavlin 76 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 dpavlin 29 =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 dpavlin 37 my $_vram_counter;
114    
115 dpavlin 29 sub vram {
116     my ( $self, $offset, $byte ) = @_;
117     my $x = ( $offset % 32 ) << 3;
118     my $y = $offset >> 5;
119     my $mask = 1;
120 dpavlin 37 my $scale = $self->scale;
121 dpavlin 29
122 dpavlin 45 printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;
123 dpavlin 29
124     foreach ( 0 .. 7 ) {
125 dpavlin 37 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 dpavlin 29 $mask = $mask << 1;
132     }
133 dpavlin 37
134     $app->sync if ( $_vram_counter++ % 10 == 0 );
135 dpavlin 29 }
136    
137 dpavlin 32 =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 dpavlin 33 return unless $self->show_mem && $self->app;
151 dpavlin 32
152 dpavlin 33 my ( $x, $y ) = $self->mem_xy( $addr );
153 dpavlin 41 warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
154 dpavlin 32
155 dpavlin 33 my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
156     $self->app->pixel( $x, $y, $col );
157 dpavlin 32
158     $_mem_stat++;
159     if ( $_mem_stat % 1000 == 0 ) {
160 dpavlin 33 $self->app->sync;
161 dpavlin 32 }
162     }
163    
164 dpavlin 33
165     =head2 sync
166    
167     $self->sync;
168    
169     =cut
170    
171     sub sync {
172     $app->sync;
173     }
174    
175 dpavlin 73 =head2 render
176    
177 dpavlin 76 Render one frame of video ram
178    
179 dpavlin 73 $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 dpavlin 75 my $pixels = pack("C*", @_);
189 dpavlin 73
190 dpavlin 75 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 dpavlin 73
200 dpavlin 75 my $rect = SDL::Rect->new( -x => 0, -y => 0, -width => 256, -height => 256 );
201 dpavlin 76 $vram->blit( $rect, $app, $rect_screen );
202 dpavlin 73
203     $app->sync;
204     }
205    
206 dpavlin 76 =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 dpavlin 55 =head1 SEE ALSO
239    
240     L<Orao> is sample implementation using this module
241    
242     =head1 AUTHOR
243    
244     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
245    
246     =head1 COPYRIGHT & LICENSE
247    
248     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
249    
250     This program is free software; you can redistribute it and/or modify it
251     under the same terms as Perl itself.
252    
253     =cut
254 dpavlin 32 1;

  ViewVC Help
Powered by ViewVC 1.1.26