/[VRac]/Orao.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 /Orao.pm

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

M6502/Orao.pm revision 33 by dpavlin, Mon Jul 30 21:00:36 2007 UTC Orao.pm revision 125 by dpavlin, Sat Aug 4 15:09:44 2007 UTC
# Line 3  package Orao; Line 3  package Orao;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use Carp;  use Carp qw/confess/;
 use lib './lib';  
 #use Time::HiRes qw(time);  
7  use File::Slurp;  use File::Slurp;
8  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
9    use M6502;
10    use Screen qw/$white $black/;
11    
12  use base qw(Class::Accessor M6502 Screen);  use base qw(Class::Accessor VRac M6502 Screen Prefs Tape);
13  __PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));  #__PACKAGE__->mk_accessors(qw());
14    
15  =head1 NAME  =head1 NAME
16    
# Line 18  Orao - Orao emulator Line 18  Orao - Orao emulator
18    
19  =head1 VERSION  =head1 VERSION
20    
21  Version 0.02  Version 0.05
22    
23  =cut  =cut
24    
25  our $VERSION = '0.02';  our $VERSION = '0.05';
26    
27  =head1 SUMMARY  =head1 SUMMARY
28    
# Line 30  Emulator or Orao 8-bit 6502 machine popu Line 30  Emulator or Orao 8-bit 6502 machine popu
30    
31  =cut  =cut
32    
33  =head2 init  =head1 FUNCTIONS
34    
35  Start emulator  =head2 boot
36    
37    Start emulator, open L<Screen>, load initial ROM images, and render memory
38    
39      my $emu = Orao->new({});
40      $emu->boot;
41    
42  =cut  =cut
43    
44  our $orao;  our $emu;
45    
46  our $PC = 0x1000;  select(STDERR); $| = 1;
47    
48  sub init {  sub boot {
49          my $self = shift;          my $self = shift;
50          warn "call upstream init\n";          warn "Orao calling upstream init\n";
51          $self->SUPER::init( $self, @_ );          $self->SUPER::init(
52                    read => sub { $self->read( @_ ) },
53                    write => sub { $self->write( @_ ) },
54            );
55    
56          warn "staring Orao $Orao::VERSION emulation\n";          warn "Orao $Orao::VERSION emulation starting\n";
57    
58            warn "emulating ", $#mem, " bytes of memory\n";
59    
60    #       $self->scale( 2 );
61    
62          $self->open_screen;          $self->open_screen;
63          $self->load_rom({          $self->load_rom({
64                  0x1000 => 'dump/SCRINV.BIN',  #               0x1000 => 'dump/SCRINV.BIN',
65                  0xC000 => 'rom/BAS12.ROM',                  # should be 0x6000, but oraoemu has 2 byte prefix
66                  0xE000 => 'rom/CRT12.ROM',  #               0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
67    #               0xC000 => 'rom/Orao/BAS12.ROM',
68    #               0xE000 => 'rom/Orao/CRT12.ROM',
69                    0xC000 => 'rom/Orao/BAS13.ROM',
70                    0xE000 => 'rom/Orao/CRT13.ROM',
71          });          });
72    
73          $orao = $self;  #       $PC = 0xDD11;   # BC
74    #       $PC = 0xC274;   # MC
75    
76  #       $self->prompt( 0x1000 );          $PC = 0xff89;
77    
78          warn "rendering memory map\n";          $emu = $self;
79    
80          my @mmap = (  #       $self->prompt( 0x1000 );
81                  0x0000, 0x03FF, 'nulti blok',  
82                  0x0400, 0x5FFF, 'korisnički RAM (23K)',          my ( $trace, $debug ) = ( $self->trace, $self->debug );
83                  0x6000, 0x7FFF, 'video RAM',          $self->trace( 0 );
84                  0x8000, 0x9FFF, 'sistemske lokacije',          $self->debug( 0 );
85                  0xA000, 0xAFFF, 'ekstenzija',  
86                  0xB000, 0xBFFF, 'DOS',          warn "rendering video memory\n";
87                  0xC000, 0xDFFF, 'BASIC ROM',          $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
88                  0xE000, 0xFFFF, 'sistemski ROM',  
89          );          if ( $self->show_mem ) {
90    
91                    warn "rendering memory map\n";
92    
93                    $self->render_mem( @mem );
94    
95                    my @mmap = (
96                            0x0000, 0x03FF, 'nulti blok',
97                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
98                            0x6000, 0x7FFF, 'video RAM',
99                            0x8000, 0x9FFF, 'sistemske lokacije',
100                            0xA000, 0xAFFF, 'ekstenzija',
101                            0xB000, 0xBFFF, 'DOS',
102                            0xC000, 0xDFFF, 'BASIC ROM',
103                            0xE000, 0xFFFF, 'sistemski ROM',
104                    );
105    
         foreach my $i ( 0 .. $#mmap / 3 ) {  
                 my $o = $i * 3;  
                 my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];  
                 printf "%04x - %04x - %s\n", $from, $to, $desc;  
 #               for my $a ( $from .. $to ) {  
 #                       $orao->read( $a );  
 #               }  
 #               $self->sync;  
106          }          }
107            $self->sync;
108            $self->trace( $trace );
109            $self->debug( $debug );
110    
111            #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
112    
113            warn "Orao boot finished",
114                    $self->trace ? ' trace' : '',
115                    $self->debug ? ' debug' : '',
116                    "\n";
117    
118            M6502::reset();
119    
120            $self->booted( 1 );
121  }  }
122    
123  =head2 load_rom  =head2 run
124    
125  called to init memory and load initial rom images  Run interactive emulation loop
126    
127    $orao->load_rom;    $emu->run;
128    
129  =cut  =cut
130    
131  sub load_rom {  sub run {
132      my ($self, $loaded_files) = @_;          my $self = shift;
133    
134      #my $time_base = time();          $self->boot if ( ! $self->booted );
135    
136          foreach my $addr ( sort keys %$loaded_files ) {  #       $self->load_tape( '../oraoigre/bdash.tap' );
137                  my $path = $loaded_files->{$addr};  
138                  $self->load_oraoemu( $path, $addr );          $self->loop;
139          }  };
140    
141    =head1 Helper functions
142    
143    =cut
144    
145    # write chunk directly into memory, updateing vram if needed
146    sub _write_chunk {
147            my $self = shift;
148            my ( $addr, $chunk ) = @_;
149            $self->write_chunk( $addr, $chunk );
150            my $end = $addr + length($chunk);
151            my ( $f, $t ) = ( 0x6000, 0x7fff );
152    
153            if ( $end < $f || $addr >= $t ) {
154                    warn "skip vram update\n";
155                    return;
156            };
157    
158            $f = $addr if ( $addr > $f );
159            $t = $end if ( $end < $t );
160    
161            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
162            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
163            $self->render_mem( @mem ) if $self->show_mem;
164  }  }
165    
166    =head2 load_image
167    
168  =head2 load_oraoemu  Load binary files, ROM images and Orao Emulator files
169    
170      $emu->load_image( '/path/to/file', 0x1000 );
171    
172    Returns true on success.
173    
174  =cut  =cut
175    
176  sub load_oraoemu {  sub load_image {
177          my $self = shift;          my $self = shift;
178          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
179    
180            if ( ! -e $path ) {
181                    warn "ERROR: file $path doesn't exist\n";
182                    return;
183            }
184    
185          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
186    
187          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 118  sub load_oraoemu { Line 189  sub load_oraoemu {
189          if ( $size == 65538 ) {          if ( $size == 65538 ) {
190                  $addr = 0;                  $addr = 0;
191                  warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;                  warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
192                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
193                  return;                  return 1;
194          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
195                  $addr = 0;                  $addr = 0;
196                  warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;                  warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
197                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
198                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
199          }          }
200          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
201          return $self->write_chunk( $addr, $buff );          $self->_write_chunk( $addr, $buff );
202            return 1;
203    
204          my $chunk;          my $chunk;
205    
# Line 144  sub load_oraoemu { Line 215  sub load_oraoemu {
215                  $pos += 4;                  $pos += 4;
216          }          }
217    
218          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
219    
220            return 1;
221  };  };
222    
 =head2 save_dump  
   
   $orao->save_dump( 'filename', $from, $to );  
   
 =cut  
   
 sub save_dump {  
         my $self = shift;  
   
         my ( $path, $from, $to ) = @_;  
   
         $from ||= 0;  
         $to ||= 0xffff;  
   
         open(my $fh, '>', $path) || die "can't open $path: $!";  
         print $fh $self->read_chunk( $from, $to );  
         close($fh);  
   
         my $size = -s $path;  
         warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;  
 }  
   
 =head2 hexdump  
   
   $orao->hexdump( $address );  
   
 =cut  
   
 sub hexdump {  
         my $self = shift;  
         my $a = shift;  
         return sprintf(" %04x %s\n", $a,  
                 join(" ",  
                         map {  
                                 sprintf( "%02x", $_ )  
                         } $self->ram( $a, $a+8 )  
                 )  
         );  
 }  
   
 =head2 prompt  
   
   $orao->prompt( $address, $last_command );  
   
 =cut  
   
 sub prompt {  
         my $self = shift;  
         my $a = shift;  
         my $last = shift;  
         print STDERR $self->hexdump( $a ),  
                 $last ? "[$last] " : '',  
                 "> ";  
         my $in = <STDIN>;  
         chomp($in);  
         $in ||= $last;  
         $last = $in;  
         return split(/\s+/, $in) if $in;  
 }  
223    
224  =head1 Memory management  =head1 Memory management
225    
# Line 215  L<Acme::6502> was just too slow to handl Line 228  L<Acme::6502> was just too slow to handl
228    
229  =cut  =cut
230    
 my @mem = (0xff) x 0x100000; # 64Mb  
   
231  =head2 read  =head2 read
232    
233  Read from memory  Read from memory
# Line 225  Read from memory Line 236  Read from memory
236    
237  =cut  =cut
238    
239    my $keyboard_none = 255;
240    
241    my $keyboard = {
242            0x87FC => {
243                    'right'         => 16,
244                    'down'          => 128,
245                    'up'            => 192,
246                    'left'          => 224,
247                    'backspace' => 224,
248            },
249            0x87FD => sub {
250                    my ( $self, $key ) = @_;
251                    if ( $key eq 'return' ) {
252                            M6502::_write( 0xfc, 13 );
253                            warn "return\n";
254                            return 0;
255                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
256                            warn "ctrl\n";
257                            return 16;
258                    }
259                    return $keyboard_none;
260            },
261            0x87FA => {
262                    'f4' => 16,
263                    'f3' => 128,
264                    'f2' => 192,
265                    'f1' => 224,
266            },
267            0x87FB => sub {
268                    my ( $self, $key ) = @_;
269                    if ( $key eq 'space' ) {
270                            return 32;
271                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
272                            warn "shift\n";
273                            return 16;
274    #               } elsif ( $self->tape ) {
275    #                       warn "has tape!";
276    #                       return 0;
277                    }
278                    return $keyboard_none;
279            },
280            0x87F6 => {
281                    '6' => 16,
282                    't' => 128,
283                    'y' => 192,     # hr: z
284                    'r' => 224,
285            },
286            0x87F7 => {
287                    '5' => 32,
288                    '4' => 16,
289            },
290            0x87EE => {
291                    '7' => 16,
292                    'u' => 128,
293                    'i' => 192,
294                    'o' => 224,
295            },
296            0x87EF => {
297                    '8' => 32,
298                    '9' => 16,
299            },
300            0x87DE => {
301                    '1' => 16,
302                    'w' => 128,
303                    'q' => 192,
304                    'e' => 224,
305            },
306            0x87DF => {
307                    '2' => 32,
308                    '3' => 16,
309            },
310            0x87BE => {
311                    'm' => 16,
312                    'k' => 128,
313                    'j' => 192,
314                    'l' => 224,
315            },
316            0x87BF => {
317                    ',' => 32,      # <
318                    '.' => 16,      # >
319            },
320            0x877E => {
321                    'z' => 16,      # hr:y
322                    's' => 128,
323                    'a' => 192,
324                    'd' => 224,
325            },
326            0x877F => {
327                    'x' => 32,
328                    'c' => 16,
329            },
330            0x86FE => {
331                    'n' => 16,
332                    'g' => 128,
333                    'h' => 192,
334                    'f' => 224,
335            },
336            0x86FF => {
337                    'b' => 32,
338                    'v' => 16,
339            },
340            0x85FE => {
341                    '<' => 16,              # :
342                    '\\' => 128,    # ¾
343                    '\'' => 192,    # ę
344                    ';' => 224,             # č
345            },
346            0x85FF => {
347                    '/' => 32,
348                    'f11' => 16,    # ^
349            },
350            0x83FE => {
351                    'f12' => 16,    # ;
352                    '[' => 128,             # ¹
353                    ']' => 192,             # š
354                    'p' => 224,
355            },
356            0x83FF => {
357                    '-' => 32,
358                    '0' => 16,
359            },
360    };
361    
362  sub read {  sub read {
363          my $self = shift;          my $self = shift;
364          my ($addr) = @_;          my ($addr) = @_;
365          my $byte = $mem[$addr];          my $byte = $mem[$addr];
366          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
367            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
368    
369            # keyboard
370    
371            if ( defined( $keyboard->{$addr} ) ) {
372                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
373                    my $key = $self->key_pressed;
374                    if ( defined($key) ) {
375                            my $ret = $keyboard_none;
376                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
377                            if ( ref($r) eq 'CODE' ) {
378                                    $ret = $r->($self, $key);
379                            } elsif ( defined($r->{$key}) ) {
380                                    $ret = $r->{$key};
381                                    if ( ref($ret) eq 'CODE' ) {
382                                            $ret = $ret->($self);
383                                    }
384                            } else {
385                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
386                            }
387                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
388                            return $ret;
389                    }
390                    return $keyboard_none;
391            }
392    
393            if ( $addr == 0x87ff ) {
394                    return $self->read_tape;
395            }
396    
397          $self->mmap_pixel( $addr, 0, $byte, 0 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
398          return $byte;          return $byte;
399  }  }
# Line 244  Write into emory Line 408  Write into emory
408    
409  sub write {  sub write {
410          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
411          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
412            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
413    
414          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr == 0x8800 ) {
415                  $self->vram( $addr - 0x6000 , $byte );                  warn sprintf "sound ignored: %x\n", $byte;
416          }          }
417    
418          if ( $addr > 0xafff ) {          if ( $addr > 0xafff ) {
419                  warn sprintf "access to %04x above affff aborting\n", $addr;                  confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
                 return -1;  
         }  
         if ( $addr == 0x8800 ) {  
                 warn sprintf "sound ignored: %x\n", $byte;  
420          }          }
421    
422          $self->mmap_pixel( $addr, $byte, 0, 0 );          $self->mmap_pixel( $addr, $byte, 0, 0 );
423    
424          $mem[$addr] = $byte;          $mem[$addr] = $byte;
425            return;
426    }
427    
428    =head2 render_vram
429    
430    Render one frame of video ram
431    
432      $self->render_vram( @video_memory );
433    
434    =cut
435    
436    my @flip;
437    
438    foreach my $i ( 0 .. 255 ) {
439            my $t = 0;
440            $i & 0b00000001 and $t = $t | 0b10000000;
441            $i & 0b00000010 and $t = $t | 0b01000000;
442            $i & 0b00000100 and $t = $t | 0b00100000;
443            $i & 0b00001000 and $t = $t | 0b00010000;
444            $i & 0b00010000 and $t = $t | 0b00001000;
445            $i & 0b00100000 and $t = $t | 0b00000100;
446            $i & 0b01000000 and $t = $t | 0b00000010;
447            $i & 0b10000000 and $t = $t | 0b00000001;
448            #warn "$i = $t\n";
449            $flip[$i] = $t;
450  }  }
451    
452    
453    sub render_vram {
454            my $self = shift;
455    
456            confess "no data?" unless (@_);
457            confess "screen size not 256*256/8 but ",($#_+1) unless (($#_+1) == (256*256/8));
458    
459            return unless $self->booted;
460    
461            my $pixels = pack("C*", map { $flip[$_] } @_);
462    
463            my $vram = SDL::Surface->new(
464                    -width => 256,
465                    -height => 256,
466                    -depth => 1,    # 1 bit per pixel
467                    -pitch => 32,   # bytes per line
468                    -from => $pixels,
469            );
470            $vram->set_colors( 0, $black, $white );
471    
472            $self->render_frame( $vram );
473    }
474    
475  =head1 AUTHOR  =head1 AUTHOR
476    
477  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.33  
changed lines
  Added in v.125
  ViewVC Help
Powered by ViewVC 1.1.26