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