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