/[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 213 by dpavlin, Mon Apr 14 21:27:19 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', 0x168 );
123            $self->load_tape( 'tapes/Orao/muzika.tap', 0x168 );
124    
125            $self->render_vram;
126    
127            $self->loop( sub {
128                    my $run_for = shift;
129                    warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
130                    M6502::exec( $run_for );
131                    $self->render_vram;
132                    $self->render_mem( M6502::mem_peek_region(0x0000,0xffff) ) if $self->show_mem;
133            });
134  };  };
135    
 =head2 load_rom  
136    
137  called to init memory and load initial rom images  =head1 Helper functions
138    
139    =head2 write_chunk
140    
141    $orao->load_rom;  Write chunk directly into memory, updateing vram if needed
142    
143      $emu->write_chunk( 0x1000, $chunk_data );
144    
145  =cut  =cut
146    
147  sub load_rom {  sub write_chunk {
148      my ($self) = @_;          my $self = shift;
149            my ( $addr, $chunk ) = @_;
150            $self->SUPER::write_chunk( $addr, $chunk );
151            my $end = $addr + length($chunk);
152            my ( $f, $t ) = ( 0x6000, 0x7fff );
153    
154            if ( $end < $f || $addr >= $t ) {
155                    warn "skip vram update\n";
156                    return;
157            };
158    
159      #my $time_base = time();          $f = $addr if ( $addr > $f );
160            $t = $end if ( $end < $t );
161    
162          foreach my $addr ( sort keys %$loaded_files ) {          warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
163                  my $path = $loaded_files->{$addr};          $self->render_vram;
164                  printf "loading '%s' at %04x\n", $path, $addr;          $self->render_mem( @mem );
                 $self->load_oraoemu( $path, $addr );  
         }  
165  }  }
166    
167    =head2 load_image
168    
169    Load binary files, ROM images and Orao Emulator files
170    
171      $emu->load_image( '/path/to/file', 0x1000 );
172    
173  =head2 load_oraoemu  Returns true on success.
174    
175  =cut  =cut
176    
177  sub load_oraoemu {  sub load_image {
178          my $self = shift;          my $self = shift;
179          my ( $path, $addr ) = @_;          my ( $path, $addr ) = @_;
180    
181            if ( ! -e $path ) {
182                    warn "ERROR: file $path doesn't exist\n";
183                    return;
184            }
185    
186          my $size = -s $path || confess "no size for $path: $!";          my $size = -s $path || confess "no size for $path: $!";
187    
188          my $buff = read_file( $path );          my $buff = read_file( $path );
189    
190          if ( $size == 65538 ) {          if ( $size == 65538 ) {
191                  $addr = 0;                  $addr = 0;
192                  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;
193                  $self->write_chunk( $addr, substr($buff,2) );                  $self->write_chunk( $addr, substr($buff,2) );
194                  return;                  return 1;
195          } elsif ( $size == 32800 ) {          } elsif ( $size == 32800 ) {
196                  $addr = 0;                  $addr = 0;
197                  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;
198                  #$self->write_chunk( $addr, substr($buff,0x20) );                  $self->write_chunk( $addr, substr($buff,0x20) );
199                  $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );                  return 1;
                 return;  
200          }          }
         printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size, $size;  
         return $self->write_chunk( $addr, $buff );  
201    
202          my $chunk;          printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
203            $self->write_chunk( $addr, $buff );
204            return 1;
205    };
206    
207    
208          my $pos = 0;  =head1 Memory management
209    
210          while ( my $long = substr($buff,$pos,4) ) {  Orao implements all I/O using mmap addresses. This was main reason why
211                  my @b = split(//, $long, 4);  L<Acme::6502> was just too slow to handle it.
212                  $chunk .=  
213                          ( $b[3] || '' ) .  =cut
214                          ( $b[2] || '' ) .  
215                          ( $b[1] || '' ) .  =head2 read
                         ( $b[0] || '' );  
                 $pos += 4;  
         }  
216    
217          $self->write_chunk( $addr, $chunk );  Read from memory
218    
219      $byte = read( $address );
220    
221    =cut
222    
223    my $keyboard_none = 255;
224    
225    my $keyboard = {
226            0x87FC => {
227                    'right'         => 16,
228                    'down'          => 128,
229                    'up'            => 192,
230                    'left'          => 224,
231                    'backspace' => 224,
232            },
233            0x87FD => sub {
234                    my $self = shift;
235                    if ( $self->key_active('return') ) {
236    #                       M6502::_write( 0xfc, 13 );
237                            warn "return\n";
238                            return 0;
239                    } elsif ( $self->key_active('left ctrl','right ctrl') ) {
240                            warn "ctrl\n";
241                            return 16;
242                    }
243                    return $keyboard_none;
244            },
245            0x87FA => {
246                    'f4' => 16,
247                    'f3' => 128,
248                    'f2' => 192,
249                    'f1' => 224,
250            },
251            0x87FB => sub {
252                    my $self = shift;
253                    if ( $self->key_active('space') ) {
254                            warn "space\n";
255                            return 32;
256                    } elsif ( $self->key_active('left shift','right shift') ) {
257                            warn "shift\n";
258                            return 16;
259    #               } elsif ( $self->tape ) {
260    #                       warn "has tape!";
261    #                       return 0;
262                    }
263                    return $keyboard_none;
264            },
265            0x87F6 => {
266                    '6' => 16,
267                    't' => 128,
268                    'y' => 192,     # hr: z
269                    'r' => 224,
270            },
271            0x87F7 => {
272                    '5' => 32,
273                    '4' => 16,
274            },
275            0x87EE => {
276                    '7' => 16,
277                    'u' => 128,
278                    'i' => 192,
279                    'o' => 224,
280            },
281            0x87EF => {
282                    '8' => 32,
283                    '9' => 16,
284            },
285            0x87DE => {
286                    '1' => 16,
287                    'w' => 128,
288                    'q' => 192,
289                    'e' => 224,
290            },
291            0x87DF => {
292                    '2' => 32,
293                    '3' => 16,
294            },
295            0x87BE => {
296                    'm' => 16,
297                    'k' => 128,
298                    'j' => 192,
299                    'l' => 224,
300            },
301            0x87BF => {
302                    ',' => 32,      # <
303                    '.' => 16,      # >
304            },
305            0x877E => {
306                    'z' => 16,      # hr:y
307                    's' => 128,
308                    'a' => 192,
309                    'd' => 224,
310            },
311            0x877F => {
312                    'x' => 32,
313                    'c' => 16,
314            },
315            0x86FE => {
316                    'n' => 16,
317                    'g' => 128,
318                    'h' => 192,
319                    'f' => 224,
320            },
321            0x86FF => {
322                    'b' => 32,
323                    'v' => 16,
324            },
325            0x85FE => {
326                    '<' => 16,              # :
327                    '\\' => 128,    # ¾
328                    '\'' => 192,    # ę
329                    ';' => 224,             # č
330            },
331            0x85FF => {
332                    '/' => 32,
333                    'f11' => 16,    # ^
334            },
335            0x83FE => {
336                    'f12' => 16,    # ;
337                    '[' => 128,             # ¹
338                    ']' => 192,             # š
339                    'p' => 224,
340            },
341            0x83FF => {
342                    '-' => 32,
343                    '0' => 16,
344            },
345  };  };
346    
347  =head2 save_dump  sub read {
348            my $self = shift;
349            my ($addr) = @_;
350            die "address over 64k: $addr" if ( $addr > 0xffff );
351            my $byte = $mem[$addr];
352            confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
353            warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
354    
355            # keyboard
356    
357            if ( defined( $keyboard->{$addr} ) ) {
358                    warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
359            
360                    my $ret = $keyboard_none;
361                    my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
362                    if ( ref($r) eq 'CODE' ) {
363                            $ret = $r->($self);
364                    } else {
365                            foreach my $k ( keys %$r ) {
366                                    my $return = 0;
367                                    if ( $self->key_active($k) ) {
368                                            warn "key '$k' is active\n";
369                                            $return ||= $r->{$k};
370                                    }
371                                    $ret = $return if $return;
372                            }
373                    }
374                    warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
375                    return $ret;
376            }
377    
378    $orao->save_dump( 'filename', $from, $to );          if ( $addr == 0x87ff ) {
379                    return $self->read_tape;
380            }
381    
382    #       $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
383            return $byte;
384    }
385    
386    =head2 write
387    
388    Write into emory
389    
390      write( $address, $byte );
391    
392  =cut  =cut
393    
394  sub save_dump {  sub write {
395          my $self = shift;          my $self = shift;
396            my ($addr,$byte) = @_;
397            warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
398    
399          my ( $path, $from, $to ) = @_;          if ( $addr == 0x8800 ) {
400                    $self->write_tape( $byte );
401                    warn sprintf "sound ignored: %x\n", $byte;
402            }
403    
404          $from ||= 0;          if ( $addr > 0xafff ) {
405          $to ||= 0xffff;                  confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
406            }
407    
408          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);  
409    
410          my $size = -s $path;          $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
411          printf "saved %s %d %x bytes\n", $path, $size, $size;  #       $mem[$addr] = $byte;
412            return;
413  }  }
414    
415  =head2 hexdump  =head1 Architecture specific
416    
417    =head2 render_vram
418    
419    $orao->hexdump( $address );  Render one frame of video ram
420    
421      $self->render_vram;
422    
423  =cut  =cut
424    
425  sub hexdump {  sub render_vram {
426          my $self = shift;          my $self = shift;
427          my $a = shift;  
428          return sprintf(" %04x %s\n", $a,  #       my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
429                  join(" ",  #       my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
430                          map {  #       my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
431                                  sprintf( "%02x", $_ )          my $pixels = pack('C*', map { $flip[$_] } unpack('C*', M6502::mem_peek_region( 0x6000, 0x7fff ) ) );
432                          } $self->ram( $a, $a+8 )  
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 prompt  =head2 cpu_PC
446    
447    $orao->prompt( $address, $last_command );  Helper metod to set or get PC for current architecture
448    
449  =cut  =cut
450    
451  sub prompt {  sub cpu_PC {
452            my ( $self, $addr ) = @_;
453            if ( defined($addr) ) {
454                    $PC = $addr;
455                    warn sprintf("running from PC %04x\n", $PC);
456            };
457            return $PC;
458    }
459    
460    
461    =head2 _init_callbacks
462    
463    Mark memory areas for which we want to get callbacks to perl
464    
465    =cut
466    
467    sub _init_callbacks {
468          my $self = shift;          my $self = shift;
469          my $a = shift;          warn "set calbacks to perl for memory areas...\n";
470          my $last = shift;  
471          print $self->hexdump( $a ),          # don't call for anything
472                  $last ? "[$last] " : '',          M6502::set_all_callbacks( 0x00 );
473                  "> ";  
474          my $in = <STDIN>;          # video ram
475          chomp($in);  #       M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
476          $in ||= $last;          # keyboard
477          $last = $in;          M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
478          return split(/\s+/, $in) if $in;          # tape
479            M6502::set_read_callback( 0x87ff );
480            M6502::set_write_callback( 0x8800 );
481    
482            my $map = '';
483            foreach ( 0 .. 0xffff ) {
484                    my $cb = M6502::get_callback( $_ );
485                    $map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
486            }
487            warn "callback map:\n$map\n";
488  }  }
489    
490    =head1 SEE ALSO
491    
492    L<VRac>, L<M6502>, L<Screen>, L<Tape>
493    
494  =head1 AUTHOR  =head1 AUTHOR
495    
496  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
497    
 =head1 BUGS  
   
498  =head1 ACKNOWLEDGEMENTS  =head1 ACKNOWLEDGEMENTS
499    
500  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.213
  ViewVC Help
Powered by ViewVC 1.1.26