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