/[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 31 by dpavlin, Mon Jul 30 18:07:29 2007 UTC Orao.pm revision 209 by dpavlin, Mon Apr 14 19:55:29 2008 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 '0.0.3';
10    use Screen;
11    
12  use base qw(Class::Accessor M6502 Screen);  use base qw(Class::Accessor VRac M6502 Screen Prefs Tape Session);
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.06
22    
23  =cut  =cut
24    
25  our $VERSION = '0.02';  our $VERSION = '0.06';
26    
27  =head1 SUMMARY  =head1 SUMMARY
28    
29  Emulator or Orao 8-bit 6502 machine popular in Croatia  Emulator for Orao 8-bit 6502 machine popular in Croatia (especially schools)
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  sub init {  our $emu;
42    
43    sub run {
44          my $self = shift;          my $self = shift;
         warn "call upstream init\n";  
         $self->SUPER::init( @_ );  
45    
46          warn "staring Orao $Orao::VERSION emulation\n";          M6502::reset();
47            $self->_init_callbacks;
48    
49            warn "Orao calling upstream init\n";
50            $self->SUPER::init(
51                    read => sub { $self->read( @_ ) },
52                    write => sub { $self->write( @_ ) },
53            );
54    
55            warn "Orao $Orao::VERSION emulation starting\n";
56    
57            warn "emulating ", $#mem, " bytes of memory\n";
58    
59    #       $self->scale( 2 );
60            $self->show_mem( 1 );
61            $self->load_session( 'sess/current' );
62    
63          $self->open_screen;          $self->open_screen;
64          $self->load_rom;          $self->load_rom({
65  }  #               0x1000 => 'dump/SCRINV.BIN',
66                    # should be 0x6000, but oraoemu has 2 byte prefix
67    #               0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
68    #               0xC000 => 'rom/Orao/BAS12.ROM',
69    #               0xE000 => 'rom/Orao/CRT12.ROM',
70                    0xC000 => 'rom/Orao/BAS13.ROM',
71                    0xE000 => 'rom/Orao/CRT13.ROM',
72            });
73    
74    #       $PC = 0xDD11;   # BC
75    #       $PC = 0xC274;   # MC
76    
77            $PC = 0xff89;
78    
79            $emu = $self;
80    
81    #       $self->prompt( 0x1000 );
82    
83            my ( $trace, $debug ) = ( $self->trace, $self->debug );
84            $self->trace( 0 );
85            $self->debug( 0 );
86    
87            warn "rendering memory\n";
88            $self->render_mem( M6502::mem_peek_region(0x0000,0xffff) );
89    
90            if ( $self->show_mem ) {
91    
92                    my @mmap = (
93                            0x0000, 0x03FF, 'nulti blok',
94                            0x0400, 0x5FFF, 'korisnički RAM (23K)',
95                            0x6000, 0x7FFF, 'video RAM',
96                            0x8000, 0x9FFF, 'sistemske lokacije',
97                            0xA000, 0xAFFF, 'ekstenzija',
98                            0xB000, 0xBFFF, 'DOS',
99                            0xC000, 0xDFFF, 'BASIC ROM',
100                            0xE000, 0xFFFF, 'sistemski ROM',
101                    );
102    
103                    print "Orao memory map:";
104    
105                    while ( @mmap ) {
106                            my ( $from, $to, $desc ) = splice(@mmap, 0, 3);
107                            printf("%04x-%04x %s\n", $from, $to, $desc);
108                    }
109    
110  my $loaded_files = {          }
111          0xC000 => 'rom/BAS12.ROM',  
112          0xE000 => 'rom/CRT12.ROM',          $self->trace( $trace );
113            $self->debug( $debug );
114    
115            warn "Orao boot finished",
116                    $self->trace ? ' trace' : '',
117                    $self->debug ? ' debug' : '',
118                    "\n";
119    
120    #       $self->load_tape( 'tapes/Orao/bdash.tap' );
121    #       $self->load_tape( 'tapes/Orao/crtanje.tap' );
122            $self->load_tape( 'tapes/Orao/jjack.tap' );
123    
124            $self->render_vram;
125    
126            $self->loop( sub {
127                    my $run_for = shift;
128                    warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
129                    M6502::exec( $run_for );
130                    $self->render_vram;
131            });
132  };  };
133    
 =head2 load_rom  
134    
135  called to init memory and load initial rom images  =head1 Helper functions
136    
137    =head2 write_chunk
138    
139    $orao->load_rom;  Write chunk directly into memory, updateing vram if needed
140    
141      $emu->write_chunk( 0x1000, $chunk_data );
142    
143  =cut  =cut
144    
145  sub load_rom {  sub write_chunk {
146      my ($self) = @_;          my $self = shift;
147            my ( $addr, $chunk ) = @_;
148            $self->SUPER::write_chunk( $addr, $chunk );
149            my $end = $addr + length($chunk);
150            my ( $f, $t ) = ( 0x6000, 0x7fff );
151    
152            if ( $end < $f || $addr >= $t ) {
153                    warn "skip vram update\n";
154                    return;
155            };
156    
157      #my $time_base = time();          $f = $addr if ( $addr > $f );
158            $t = $end if ( $end < $t );
159    
160          foreach my $addr ( sort keys %$loaded_files ) {          warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
161                  my $path = $loaded_files->{$addr};          $self->render_vram;
162                  printf "loading '%s' at %04x\n", $path, $addr;          $self->render_mem( @mem );
                 $self->load_oraoemu( $path, $addr );  
         }  
163  }  }
164    
165    =head2 load_image
166    
167    Load binary files, ROM images and Orao Emulator files
168    
169      $emu->load_image( '/path/to/file', 0x1000 );
170    
171  =head2 load_oraoemu  Returns true on success.
172    
173  =cut  =cut
174    
175  sub load_oraoemu {  sub load_image {
176          my $self = shift;          my $self = shift;
177          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
178    
179            if ( ! -e $path ) {
180                    warn "ERROR: file $path doesn't exist\n";
181                    return;
182            }
183    
184          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
185    
186          my $buff = read_file( $path );          my $buff = read_file( $path );
187    
188          if ( $size == 65538 ) {          if ( $size == 65538 ) {
189                  $addr = 0;                  $addr = 0;
190                  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;
191                  $self->write_chunk( $addr, substr($buff,2) );                  $self->write_chunk( $addr, substr($buff,2) );
192                  return;                  return 1;
193          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
194                  $addr = 0;                  $addr = 0;
195                  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;
196                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->write_chunk( $addr, substr($buff,0x20) );
197                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
198          }          }
         printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $size;  
         return $self->write_chunk( $addr, $buff );  
199    
200          my $chunk;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
201            $self->write_chunk( $addr, $buff );
202            return 1;
203    };
204    
205    
206          my $pos = 0;  =head1 Memory management
207    
208          while ( my $long = substr($buff,$pos,4) ) {  Orao implements all I/O using mmap addresses. This was main reason why
209                  my @b = split(//, $long, 4);  L<Acme::6502> was just too slow to handle it.
210                  $chunk .=  
211                          ( $b[3] || '' ) .  =cut
212                          ( $b[2] || '' ) .  
213                          ( $b[1] || '' ) .  =head2 read
                         ( $b[0] || '' );  
                 $pos += 4;  
         }  
214    
215          $self->write_chunk( $addr, $chunk );  Read from memory
216    
217      $byte = read( $address );
218    
219    =cut
220    
221    my $keyboard_none = 255;
222    
223    my $keyboard = {
224            0x87FC => {
225                    'right'         => 16,
226                    'down'          => 128,
227                    'up'            => 192,
228                    'left'          => 224,
229                    'backspace' => 224,
230            },
231            0x87FD => sub {
232                    my $self = shift;
233                    if ( $self->key_active('return') ) {
234    #                       M6502::_write( 0xfc, 13 );
235                            warn "return\n";
236                            return 0;
237                    } elsif ( $self->key_active('left ctrl','right ctrl') ) {
238                            warn "ctrl\n";
239                            return 16;
240                    }
241                    return $keyboard_none;
242            },
243            0x87FA => {
244                    'f4' => 16,
245                    'f3' => 128,
246                    'f2' => 192,
247                    'f1' => 224,
248            },
249            0x87FB => sub {
250                    my $self = shift;
251                    if ( $self->key_active('space') ) {
252                            warn "space\n";
253                            return 32;
254                    } elsif ( $self->key_active('left shift','right shift') ) {
255                            warn "shift\n";
256                            return 16;
257    #               } elsif ( $self->tape ) {
258    #                       warn "has tape!";
259    #                       return 0;
260                    }
261                    return $keyboard_none;
262            },
263            0x87F6 => {
264                    '6' => 16,
265                    't' => 128,
266                    'y' => 192,     # hr: z
267                    'r' => 224,
268            },
269            0x87F7 => {
270                    '5' => 32,
271                    '4' => 16,
272            },
273            0x87EE => {
274                    '7' => 16,
275                    'u' => 128,
276                    'i' => 192,
277                    'o' => 224,
278            },
279            0x87EF => {
280                    '8' => 32,
281                    '9' => 16,
282            },
283            0x87DE => {
284                    '1' => 16,
285                    'w' => 128,
286                    'q' => 192,
287                    'e' => 224,
288            },
289            0x87DF => {
290                    '2' => 32,
291                    '3' => 16,
292            },
293            0x87BE => {
294                    'm' => 16,
295                    'k' => 128,
296                    'j' => 192,
297                    'l' => 224,
298            },
299            0x87BF => {
300                    ',' => 32,      # <
301                    '.' => 16,      # >
302            },
303            0x877E => {
304                    'z' => 16,      # hr:y
305                    's' => 128,
306                    'a' => 192,
307                    'd' => 224,
308            },
309            0x877F => {
310                    'x' => 32,
311                    'c' => 16,
312            },
313            0x86FE => {
314                    'n' => 16,
315                    'g' => 128,
316                    'h' => 192,
317                    'f' => 224,
318            },
319            0x86FF => {
320                    'b' => 32,
321                    'v' => 16,
322            },
323            0x85FE => {
324                    '<' => 16,              # :
325                    '\\' => 128,    # ¾
326                    '\'' => 192,    # ę
327                    ';' => 224,             # č
328            },
329            0x85FF => {
330                    '/' => 32,
331                    'f11' => 16,    # ^
332            },
333            0x83FE => {
334                    'f12' => 16,    # ;
335                    '[' => 128,             # ¹
336                    ']' => 192,             # š
337                    'p' => 224,
338            },
339            0x83FF => {
340                    '-' => 32,
341                    '0' => 16,
342            },
343  };  };
344    
345  =head2 save_dump  sub read {
346            my $self = shift;
347            my ($addr) = @_;
348            die "address over 64k: $addr" if ( $addr > 0xffff );
349            my $byte = $mem[$addr];
350            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
351            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
352    
353            # keyboard
354    
355            if ( defined( $keyboard->{$addr} ) ) {
356                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
357            
358                    my $ret = $keyboard_none;
359                    my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
360                    if ( ref($r) eq 'CODE' ) {
361                            $ret = $r->($self);
362                    } else {
363                            foreach my $k ( keys %$r ) {
364                                    my $return = 0;
365                                    if ( $self->key_active($k) ) {
366                                            warn "key '$k' is active\n";
367                                            $return ||= $r->{$k};
368                                    }
369                                    $ret = $return if $return;
370                            }
371                    }
372                    warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
373                    return $ret;
374            }
375    
376    $orao->save_dump( 'filename', $from, $to );          if ( $addr == 0x87ff ) {
377                    return $self->read_tape;
378            }
379    
380            $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
381            return $byte;
382    }
383    
384    =head2 write
385    
386    Write into emory
387    
388      write( $address, $byte );
389    
390  =cut  =cut
391    
392  sub save_dump {  sub write {
393          my $self = shift;          my $self = shift;
394            my ($addr,$byte) = @_;
395            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
396    
397          my ( $path, $from, $to ) = @_;          if ( $addr == 0x8800 ) {
398                    $self->write_tape( $byte );
399                    warn sprintf "sound ignored: %x\n", $byte;
400            }
401    
402          $from ||= 0;          if ( $addr > 0xafff ) {
403          $to ||= 0xffff;                  confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
404            }
405    
406          open(my $fh, '>', $path) || die "can't open $path: $!";          $self->render_vram if ( $addr >= 0x6000 && $addr <= 0x7fff );
         print $fh $self->read_chunk( $from, $to );  
         close($fh);  
407    
408          my $size = -s $path;          $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
409          printf "saved %s %d %x bytes\n", $path, $size, $size;  #       $mem[$addr] = $byte;
410            return;
411  }  }
412    
413  =head2 hexdump  =head1 Architecture specific
414    
415    =head2 render_vram
416    
417    $orao->hexdump( $address );  Render one frame of video ram
418    
419      $self->render_vram;
420    
421  =cut  =cut
422    
423  sub hexdump {  sub render_vram {
424          my $self = shift;          my $self = shift;
425          my $a = shift;  
426          return sprintf(" %04x %s\n", $a,  #       my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
427                  join(" ",  #       my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
428                          map {          my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
429                                  sprintf( "%02x", $_ )  
430                          } $self->ram( $a, $a+8 )          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 prompt  =head2 cpu_PC
443    
444    $orao->prompt( $address, $last_command );  Helper metod to set or get PC for current architecture
445    
446  =cut  =cut
447    
448  sub prompt {  sub cpu_PC {
449            my ( $self, $addr ) = @_;
450            if ( defined($addr) ) {
451                    $PC = $addr;
452                    warn sprintf("running from PC %04x\n", $PC);
453            };
454            return $PC;
455    }
456    
457    
458    =head2 _init_callbacks
459    
460    Mark memory areas for which we want to get callbacks to perl
461    
462    =cut
463    
464    sub _init_callbacks {
465          my $self = shift;          my $self = shift;
466          my $a = shift;          warn "set calbacks to perl for memory areas...\n";
467          my $last = shift;  
468          print $self->hexdump( $a ),          # don't call for anything
469                  $last ? "[$last] " : '',          M6502::set_all_callbacks( 0x00 );
470                  "> ";  
471          my $in = <STDIN>;          # video ram
472          chomp($in);  #       M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
473          $in ||= $last;          # keyboard
474          $last = $in;          M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
475          return split(/\s+/, $in) if $in;          # tape
476            M6502::set_read_callback( 0x87ff );
477            M6502::set_write_callback( 0x8800 );
478    
479            my $map = '';
480            foreach ( 0 .. 0xffff ) {
481                    my $cb = M6502::get_callback( $_ );
482                    $map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
483            }
484            warn "callback map:\n$map\n";
485  }  }
486    
487    =head1 SEE ALSO
488    
489    L<VRac>, L<M6502>, L<Screen>, L<Tape>
490    
491  =head1 AUTHOR  =head1 AUTHOR
492    
493  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
494    
 =head1 BUGS  
   
495  =head1 ACKNOWLEDGEMENTS  =head1 ACKNOWLEDGEMENTS
496    
497  See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all  See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
Legend:
Removed from v.31  
changed lines
  Added in v.209
  ViewVC Help
Powered by ViewVC 1.1.26