/[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 29 by dpavlin, Mon Jul 30 17:32:41 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/;
9    use M6502; # import @mem $PC and friends
10    use Screen qw/$white $black/;
11    
12  use base qw(Class::Accessor M6502);  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 17  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 29  Emulator or Orao 8-bit 6502 machine popu Line 30  Emulator or Orao 8-bit 6502 machine popu
30    
31  =cut  =cut
32    
33  my $loaded_files = {  =head1 FUNCTIONS
34          0xC000 => 'rom/BAS12.ROM',  
35          0xE000 => 'rom/CRT12.ROM',  =head2 run
36    
37    Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
38    
39    =cut
40    
41    our $emu;
42    
43    sub run {
44            my $self = shift;
45    
46            warn "Orao calling upstream init\n";
47            $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    #       $self->scale( 2 );
57    
58            $self->open_screen;
59            $self->load_rom({
60    #               0x1000 => 'dump/SCRINV.BIN',
61                    # should be 0x6000, but oraoemu has 2 byte prefix
62    #               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    #       $PC = 0xDD11;   # BC
70    #       $PC = 0xC274;   # MC
71    
72            $PC = 0xff89;
73    
74            $emu = $self;
75    
76    #       $self->prompt( 0x1000 );
77    
78            my ( $trace, $debug ) = ( $self->trace, $self->debug );
79            $self->trace( 0 );
80            $self->debug( 0 );
81    
82            warn "rendering video memory\n";
83            $self->render_vram;
84    
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    
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    
 =head2 load_rom  
126    
127  called to init memory and load initial rom images  =head1 Helper functions
128    
129    =head2 write_chunk
130    
131    $orao->load_rom;  Write chunk directly into memory, updateing vram if needed
132    
133      $emu->write_chunk( 0x1000, $chunk_data );
134    
135  =cut  =cut
136    
137  sub load_rom {  sub write_chunk {
138      my ($self) = @_;          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      #my $time_base = time();          if ( $end < $f || $addr >= $t ) {
145                    warn "skip vram update\n";
146                    return;
147            };
148    
149          foreach my $addr ( sort keys %$loaded_files ) {          $f = $addr if ( $addr > $f );
150                  my $path = $loaded_files->{$addr};          $t = $end if ( $end < $t );
151                  printf "loading '%s' at %04x\n", $path, $addr;  
152                  $self->load_oraoemu( $path, $addr );          warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
153          }          $self->render_vram;
154            $self->render_mem( @mem ) if $self->show_mem;
155  }  }
156    
157    =head2 load_image
158    
159    Load binary files, ROM images and Orao Emulator files
160    
161  =head2 load_oraoemu    $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          my $size = -s $path || die "no size for $path: $!";          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: $!";
177    
178          my $buff = read_file( $path );          my $buff = read_file( $path );
179    
180          if ( $size == 65538 ) {          if ( $size == 65538 ) {
181                  $addr = 0;                  $addr = 0;
182                  printf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $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                  printf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $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;  
190          }          }
         printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $size;  
         return $self->write_chunk( $addr, $buff );  
191    
192          my $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    
         my $pos = 0;  
197    
198          while ( my $long = substr($buff,$pos,4) ) {  =head1 Memory management
199                  my @b = split(//, $long, 4);  
200                  $chunk .=  Orao implements all I/O using mmap addresses. This was main reason why
201                          ( $b[3] || '' ) .  L<Acme::6502> was just too slow to handle it.
202                          ( $b[2] || '' ) .  
203                          ( $b[1] || '' ) .  =cut
                         ( $b[0] || '' );  
                 $pos += 4;  
         }  
204    
205          $self->write_chunk( $addr, $chunk );  =head2 read
206    
207    Read from memory
208    
209      $byte = read( $address );
210    
211    =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  =head2 save_dump  sub read {
337            my $self = shift;
338            my ($addr) = @_;
339            return if ( $addr > 0xffff );
340            my $byte = $mem[$addr];
341            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 );
373            return $byte;
374    }
375    
376    =head2 write
377    
378    Write into emory
379    
380    $orao->save_dump( 'filename', $from, $to );    write( $address, $byte );
381    
382  =cut  =cut
383    
384  sub save_dump {  sub write {
385          my $self = shift;          my $self = shift;
386            my ($addr,$byte) = @_;
387            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
388    
389          my ( $path, $from, $to ) = @_;          if ( $addr == 0x8800 ) {
390                    warn sprintf "sound ignored: %x\n", $byte;
391            }
392    
393          $from ||= 0;          if ( $addr > 0xafff ) {
394          $to ||= 0xffff;                  confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
395            }
396    
397          open(my $fh, '>', $path) || die "can't open $path: $!";          $self->mmap_pixel( $addr, $byte, 0, 0 );
         print $fh $self->read_chunk( $from, $to );  
         close($fh);  
398    
399          my $size = -s $path;          $mem[$addr] = $byte;
400          printf "saved %s %d %x bytes\n", $path, $size, $size;          return;
401  }  }
402    
403  =head2 hexdump  =head2 render_vram
404    
405    $orao->hexdump( $address );  Render one frame of video ram
406    
407      $self->render_vram;
408    
409  =cut  =cut
410    
411  sub hexdump {  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;          my $self = shift;
430          my $a = shift;  
431          return sprintf(" %04x %s\n", $a,          my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
432                  join(" ",  
433                          map {          my $vram = SDL::Surface->new(
434                                  sprintf( "%02x", $_ )                  -width => 256,
435                          } $self->ram( $a, $a+8 )                  -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  =head2 prompt          $self->render_frame( $vram );
443    }
444    
445    $orao->prompt( $address, $last_command );  =head2 cpu_PC
446    
447  =cut  =cut
448    
449  sub prompt {  sub cpu_PC {
450          my $self = shift;          my ( $self, $addr ) = @_;
451          my $a = shift;          if ( defined($addr) ) {
452          my $last = shift;                  $PC = $addr;
453          print $self->hexdump( $a ),                  warn sprintf("running from PC %04x\n", $PC);
454                  $last ? "[$last] " : '',          };
455                  "> ";          return $PC;
         my $in = <STDIN>;  
         chomp($in);  
         $in ||= $last;  
         $last = $in;  
         return split(/\s+/, $in) if $in;  
456  }  }
457    
458  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.29  
changed lines
  Added in v.132
  ViewVC Help
Powered by ViewVC 1.1.26