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