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

Diff of /Screen.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 29 by dpavlin, Mon Jul 30 17:32:41 2007 UTC revision 73 by dpavlin, Tue Jul 31 21:43:57 2007 UTC
# Line 9  use SDL::App; Line 9  use SDL::App;
9  use SDL::Rect;  use SDL::Rect;
10  use SDL::Color;  use SDL::Color;
11    
12  use base qw(Class::Accessor);  use Carp qw/confess/;
 __PACKAGE__->mk_accessors(qw(debug scale show_mem run_for mem_dump trace));  
13    
14  =head2 init  use base qw(Class::Accessor Prefs);
15    __PACKAGE__->mk_accessors(qw(app));
16    
17    =head1 NAME
18    
19    Screen - simulated 256*256 pixels monochrome screen using SDL
20    
21    =head2 open_screen
22    
23  Open simulated screen  Open simulated screen
24    
# Line 20  Open simulated screen Line 26  Open simulated screen
26    
27  our $app;  our $app;
28    
29  sub init {  sub open_screen {
30          my $self = shift;          my $self = shift;
31    
32            $self->prefs;
33    
34            if ( ! $self->scale ) {
35                    $self->scale( 1 );
36                    warn "using default unscaled display\n";
37            }
38    
39          $app = SDL::App->new(          $app = SDL::App->new(
40                  -width  => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),                  -width  => 256 * $self->scale + ( $self->show_mem ? 256 : 0 ),
41                  -height => 256 * $self->scale,                  -height => 256 * $self->scale,
# Line 30  sub init { Line 44  sub init {
44          #$app->grab_input( 0 );          #$app->grab_input( 0 );
45    
46          warn "# created SDL::App\n";          warn "# created SDL::App\n";
47            $self->app( $app );
48  }  }
49    
50  my $white       = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );  my $white       = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff );
# Line 89  Push byte to video memory and draw it Line 104  Push byte to video memory and draw it
104    
105  =cut  =cut
106    
107    my $_vram_counter;
108    
109  sub vram {  sub vram {
110          my ( $self, $offset, $byte ) = @_;          my ( $self, $offset, $byte ) = @_;
111          my $x = ( $offset % 32 ) << 3;          my $x = ( $offset % 32 ) << 3;
112          my $y = $offset >> 5;          my $y = $offset >> 5;
113          my $mask = 1;          my $mask = 1;
114            my $scale = $self->scale;
115    
116          printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;          printf "## vram %04x %02x*%02x %02x\n", $offset, $x, $y, $byte if $self->trace;
117    
118          foreach ( 0 .. 7 ) {          foreach ( 0 .. 7 ) {
119                  p($x + $_, $y, $byte & $mask );                  my $on = $byte & $mask;
120                    if ( $scale == 1 ) {
121                            $app->pixel( $x + $_, $y, $on ? $white : $black );
122                    } else {
123                            $self->p($x + $_, $y, $on );
124                    }
125                  $mask = $mask << 1;                  $mask = $mask << 1;
126          }          }
127    
128            $app->sync if ( $_vram_counter++ % 10 == 0 );
129    }
130    
131    =head2 mmap_pixel
132    
133    Draw pixel in memory map
134    
135      $self->mmap_pixel( $addr, $r, $g, $b );
136    
137    =cut
138    
139    # keep accesses to memory
140    my $_mem_stat;
141    
142    sub mmap_pixel {
143            my ( $self, $addr, $r, $g, $b ) = @_;
144            return unless $self->show_mem && $self->app;
145    
146            my ( $x, $y ) = $self->mem_xy( $addr );
147            warn sprintf "## mem %04x %02x %02x %02d*%02d\n", $addr, $r, $g, $x, $y if $self->debug;
148    
149            my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b );
150            $self->app->pixel( $x, $y, $col );
151    
152            $_mem_stat++;
153            if ( $_mem_stat % 1000 == 0 ) {
154                    $self->app->sync;
155            }
156    }
157    
158    
159    =head2 sync
160    
161      $self->sync;
162    
163    =cut
164    
165    sub sync {
166            $app->sync;
167    }
168    
169    =head2 render
170    
171      $self->render( @video_memory );
172    
173    =cut
174    
175    sub render {
176            my $self = shift;
177    
178            die "this function isn't supported if scale isn't 1" unless $self->scale == 1;
179    
180            $app->lock;
181    
182            my ( $x, $y ) = ( 0,0 );
183    
184            foreach my $b ( @_ ) {
185                    foreach my $p ( split(//, unpack("B8",pack("C",$b)) ) ) {
186                            $app->pixel( $x, $y, $p ? $white : $black );
187                            $x++;
188                    }
189                    if ( $x == 256 ) {
190                            $x = 0;
191                            $y++;
192                    }
193            }
194    
195            $app->unlock;
196            $app->sync;
197    
198            warn "Screen::render over\n";
199  }  }
200    
201    =head1 SEE ALSO
202    
203    L<Orao> is sample implementation using this module
204    
205    =head1 AUTHOR
206    
207    Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
208    
209    =head1 COPYRIGHT & LICENSE
210    
211    Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
212    
213    This program is free software; you can redistribute it and/or modify it
214    under the same terms as Perl itself.
215    
216    =cut
217    1;
Legend:
Removed from v.29  
changed lines
  Added in v.73
  ViewVC Help
Powered by ViewVC 1.1.26