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