/[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 126 by dpavlin, Sat Aug 4 15:43:28 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 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 "Orao calling 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          warn "Orao init finished\n";          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( sub {
139          }                  M6502::exec( $_[0] );
140                    $self->render_vram;
141            });
142    };
143    
144    =head1 Helper functions
145    
146    =cut
147    
148    # write chunk directly into memory, updateing vram if needed
149    sub _write_chunk {
150            my $self = shift;
151            my ( $addr, $chunk ) = @_;
152            $self->write_chunk( $addr, $chunk );
153            my $end = $addr + length($chunk);
154            my ( $f, $t ) = ( 0x6000, 0x7fff );
155    
156            if ( $end < $f || $addr >= $t ) {
157                    warn "skip vram update\n";
158                    return;
159            };
160    
161            $f = $addr if ( $addr > $f );
162            $t = $end if ( $end < $t );
163    
164            warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
165            $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
166            $self->render_mem( @mem ) if $self->show_mem;
167  }  }
168    
169    =head2 load_image
170    
171  =head2 load_oraoemu  Load binary files, ROM images and Orao Emulator files
172    
173      $emu->load_image( '/path/to/file', 0x1000 );
174    
175    Returns true on success.
176    
177  =cut  =cut
178    
179  sub load_oraoemu {  sub load_image {
180          my $self = shift;          my $self = shift;
181          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
182    
183            if ( ! -e $path ) {
184                    warn "ERROR: file $path doesn't exist\n";
185                    return;
186            }
187    
188          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
189    
190          my $buff = read_file( $path );          my $buff = read_file( $path );
# Line 121  sub load_oraoemu { Line 192  sub load_oraoemu {
192          if ( $size == 65538 ) {          if ( $size == 65538 ) {
193                  $addr = 0;                  $addr = 0;
194                  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;
195                  $self->write_chunk( $addr, substr($buff,2) );                  $self->_write_chunk( $addr, substr($buff,2) );
196                  return;                  return 1;
197          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
198                  $addr = 0;                  $addr = 0;
199                  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;
200                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->_write_chunk( $addr, substr($buff,0x20) );
201                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
202          }          }
203          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;
204          return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );          $self->_write_chunk( $addr, $buff );
205          return $self->write_chunk( $addr, $buff );          return 1;
206    
207          my $chunk;          my $chunk;
208    
# Line 148  sub load_oraoemu { Line 218  sub load_oraoemu {
218                  $pos += 4;                  $pos += 4;
219          }          }
220    
221          $self->write_chunk( $addr, $chunk );          $self->_write_chunk( $addr, $chunk );
222    
223            return 1;
224  };  };
225    
 =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;  
 }  
226    
227  =head1 Memory management  =head1 Memory management
228    
# Line 227  Read from memory Line 239  Read from memory
239    
240  =cut  =cut
241    
242    my $keyboard_none = 255;
243    
244    my $keyboard = {
245            0x87FC => {
246                    'right'         => 16,
247                    'down'          => 128,
248                    'up'            => 192,
249                    'left'          => 224,
250                    'backspace' => 224,
251            },
252            0x87FD => sub {
253                    my ( $self, $key ) = @_;
254                    if ( $key eq 'return' ) {
255                            M6502::_write( 0xfc, 13 );
256                            warn "return\n";
257                            return 0;
258                    } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
259                            warn "ctrl\n";
260                            return 16;
261                    }
262                    return $keyboard_none;
263            },
264            0x87FA => {
265                    'f4' => 16,
266                    'f3' => 128,
267                    'f2' => 192,
268                    'f1' => 224,
269            },
270            0x87FB => sub {
271                    my ( $self, $key ) = @_;
272                    if ( $key eq 'space' ) {
273                            return 32;
274                    } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
275                            warn "shift\n";
276                            return 16;
277    #               } elsif ( $self->tape ) {
278    #                       warn "has tape!";
279    #                       return 0;
280                    }
281                    return $keyboard_none;
282            },
283            0x87F6 => {
284                    '6' => 16,
285                    't' => 128,
286                    'y' => 192,     # hr: z
287                    'r' => 224,
288            },
289            0x87F7 => {
290                    '5' => 32,
291                    '4' => 16,
292            },
293            0x87EE => {
294                    '7' => 16,
295                    'u' => 128,
296                    'i' => 192,
297                    'o' => 224,
298            },
299            0x87EF => {
300                    '8' => 32,
301                    '9' => 16,
302            },
303            0x87DE => {
304                    '1' => 16,
305                    'w' => 128,
306                    'q' => 192,
307                    'e' => 224,
308            },
309            0x87DF => {
310                    '2' => 32,
311                    '3' => 16,
312            },
313            0x87BE => {
314                    'm' => 16,
315                    'k' => 128,
316                    'j' => 192,
317                    'l' => 224,
318            },
319            0x87BF => {
320                    ',' => 32,      # <
321                    '.' => 16,      # >
322            },
323            0x877E => {
324                    'z' => 16,      # hr:y
325                    's' => 128,
326                    'a' => 192,
327                    'd' => 224,
328            },
329            0x877F => {
330                    'x' => 32,
331                    'c' => 16,
332            },
333            0x86FE => {
334                    'n' => 16,
335                    'g' => 128,
336                    'h' => 192,
337                    'f' => 224,
338            },
339            0x86FF => {
340                    'b' => 32,
341                    'v' => 16,
342            },
343            0x85FE => {
344                    '<' => 16,              # :
345                    '\\' => 128,    # ¾
346                    '\'' => 192,    # ę
347                    ';' => 224,             # č
348            },
349            0x85FF => {
350                    '/' => 32,
351                    'f11' => 16,    # ^
352            },
353            0x83FE => {
354                    'f12' => 16,    # ;
355                    '[' => 128,             # ¹
356                    ']' => 192,             # š
357                    'p' => 224,
358            },
359            0x83FF => {
360                    '-' => 32,
361                    '0' => 16,
362            },
363    };
364    
365  sub read {  sub read {
366          my $self = shift;          my $self = shift;
367          my ($addr) = @_;          my ($addr) = @_;
368          my $byte = $mem[$addr];          my $byte = $mem[$addr];
369          warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;          confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
370            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
371    
372            # keyboard
373    
374            if ( defined( $keyboard->{$addr} ) ) {
375                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
376                    my $key = $self->key_pressed;
377                    if ( defined($key) ) {
378                            my $ret = $keyboard_none;
379                            my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
380                            if ( ref($r) eq 'CODE' ) {
381                                    $ret = $r->($self, $key);
382                            } elsif ( defined($r->{$key}) ) {
383                                    $ret = $r->{$key};
384                                    if ( ref($ret) eq 'CODE' ) {
385                                            $ret = $ret->($self);
386                                    }
387                            } else {
388                                    warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
389                            }
390                            warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
391                            return $ret;
392                    }
393                    return $keyboard_none;
394            }
395    
396            if ( $addr == 0x87ff ) {
397                    return $self->read_tape;
398            }
399    
400          $self->mmap_pixel( $addr, 0, $byte, 0 );          $self->mmap_pixel( $addr, 0, $byte, 0 );
401          return $byte;          return $byte;
402  }  }
# Line 246  Write into emory Line 411  Write into emory
411    
412  sub write {  sub write {
413          my $self = shift;          my $self = shift;
         warn "# Orao::write(",dump(@_),")\n" if $self->debug;  
414          my ($addr,$byte) = @_;          my ($addr,$byte) = @_;
415            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
416    
417          if ( $addr >= 0x6000 && $addr < 0x8000 ) {          if ( $addr == 0x8800 ) {
418                  $self->vram( $addr - 0x6000 , $byte );                  warn sprintf "sound ignored: %x\n", $byte;
419          }          }
420    
421          if ( $addr > 0xafff ) {          if ( $addr > 0xafff ) {
422                  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;  
423          }          }
424    
425          $self->mmap_pixel( $addr, $byte, 0, 0 );          $self->mmap_pixel( $addr, $byte, 0, 0 );
426    
427          $mem[$addr] = $byte;          $mem[$addr] = $byte;
428            return;
429  }  }
430    
431    =head2 render_vram
432    
433    Render one frame of video ram
434    
435      $self->render_vram;
436    
437    =cut
438    
439    my @flip;
440    
441    foreach my $i ( 0 .. 255 ) {
442            my $t = 0;
443            $i & 0b00000001 and $t = $t | 0b10000000;
444            $i & 0b00000010 and $t = $t | 0b01000000;
445            $i & 0b00000100 and $t = $t | 0b00100000;
446            $i & 0b00001000 and $t = $t | 0b00010000;
447            $i & 0b00010000 and $t = $t | 0b00001000;
448            $i & 0b00100000 and $t = $t | 0b00000100;
449            $i & 0b01000000 and $t = $t | 0b00000010;
450            $i & 0b10000000 and $t = $t | 0b00000001;
451            #warn "$i = $t\n";
452            $flip[$i] = $t;
453    }
454    
455    
456    sub render_vram {
457            my $self = shift;
458    
459            return unless $self->booted;
460    
461            my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
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    
Legend:
Removed from v.34  
changed lines
  Added in v.126
  ViewVC Help
Powered by ViewVC 1.1.26