package Orao;
use warnings;
use strict;
use Carp qw/confess/;
use File::Slurp;
use Data::Dump qw/dump/;
use M6502 '0.0.3';
use Screen;
use base qw(Class::Accessor VRac M6502 Screen Prefs Tape Session);
#__PACKAGE__->mk_accessors(qw());
=head1 NAME
Orao - Orao emulator
=head1 VERSION
Version 0.06
=cut
our $VERSION = '0.06';
=head1 SUMMARY
Emulator for Orao 8-bit 6502 machine popular in Croatia (especially schools)
=cut
=head1 FUNCTIONS
=head2 run
Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
=cut
our $emu;
sub run {
my $self = shift;
M6502::reset();
$self->_init_callbacks;
warn "Orao calling upstream init\n";
$self->SUPER::init(
read => sub { $self->read( @_ ) },
write => sub { $self->write( @_ ) },
);
warn "Orao $Orao::VERSION emulation starting\n";
warn "emulating ", $#mem, " bytes of memory\n";
# $self->scale( 2 );
$self->show_mem( 1 );
$self->load_session( 'sess/current' );
$self->open_screen;
$self->load_rom({
# 0x1000 => 'dump/SCRINV.BIN',
# should be 0x6000, but oraoemu has 2 byte prefix
# 0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
# 0xC000 => 'rom/Orao/BAS12.ROM',
# 0xE000 => 'rom/Orao/CRT12.ROM',
0xC000 => 'rom/Orao/BAS13.ROM',
0xE000 => 'rom/Orao/CRT13.ROM',
});
# $PC = 0xDD11; # BC
# $PC = 0xC274; # MC
$PC = 0xff89;
$emu = $self;
# $self->prompt( 0x1000 );
my ( $trace, $debug ) = ( $self->trace, $self->debug );
$self->trace( 0 );
$self->debug( 0 );
warn "rendering memory\n";
$self->render_mem( M6502::mem_peek_region(0x0000,0xffff) );
if ( $self->show_mem ) {
my @mmap = (
0x0000, 0x03FF, 'nulti blok',
0x0400, 0x5FFF, 'korisnički RAM (23K)',
0x6000, 0x7FFF, 'video RAM',
0x8000, 0x9FFF, 'sistemske lokacije',
0xA000, 0xAFFF, 'ekstenzija',
0xB000, 0xBFFF, 'DOS',
0xC000, 0xDFFF, 'BASIC ROM',
0xE000, 0xFFFF, 'sistemski ROM',
);
print "Orao memory map:";
while ( @mmap ) {
my ( $from, $to, $desc ) = splice(@mmap, 0, 3);
printf("%04x-%04x %s\n", $from, $to, $desc);
}
}
$self->trace( $trace );
$self->debug( $debug );
warn "Orao boot finished",
$self->trace ? ' trace' : '',
$self->debug ? ' debug' : '',
"\n";
# $self->load_tape( 'tapes/Orao/bdash.tap' );
# $self->load_tape( 'tapes/Orao/crtanje.tap' );
# $self->load_tape( 'tapes/Orao/jjack.tap', 0x168 );
$self->load_tape( 'tapes/Orao/muzika.tap', 0x168 );
$self->render_vram;
$self->loop( sub {
my $run_for = shift;
warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
M6502::exec( $run_for );
$self->render_vram;
$self->render_mem( M6502::mem_peek_region(0x0000,0xffff) ) if $self->show_mem;
});
};
=head1 Helper functions
=head2 write_chunk
Write chunk directly into memory, updateing vram if needed
$emu->write_chunk( 0x1000, $chunk_data );
=cut
sub write_chunk {
my $self = shift;
my ( $addr, $chunk ) = @_;
$self->SUPER::write_chunk( $addr, $chunk );
my $end = $addr + length($chunk);
my ( $f, $t ) = ( 0x6000, 0x7fff );
if ( $end < $f || $addr >= $t ) {
warn "skip vram update\n";
return;
};
$f = $addr if ( $addr > $f );
$t = $end if ( $end < $t );
warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
$self->render_vram;
$self->render_mem( @mem );
}
=head2 load_image
Load binary files, ROM images and Orao Emulator files
$emu->load_image( '/path/to/file', 0x1000 );
Returns true on success.
=cut
sub load_image {
my $self = shift;
my ( $path, $addr ) = @_;
if ( ! -e $path ) {
warn "ERROR: file $path doesn't exist\n";
return;
}
my $size = -s $path || confess "no size for $path: $!";
my $buff = read_file( $path );
if ( $size == 65538 ) {
$addr = 0;
warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
$self->write_chunk( $addr, substr($buff,2) );
return 1;
} elsif ( $size == 32800 ) {
$addr = 0;
warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
$self->write_chunk( $addr, substr($buff,0x20) );
return 1;
}
printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
$self->write_chunk( $addr, $buff );
return 1;
};
=head1 Memory management
Orao implements all I/O using mmap addresses. This was main reason why
L<Acme::6502> was just too slow to handle it.
=cut
=head2 read
Read from memory
$byte = read( $address );
=cut
my $keyboard_none = 255;
my $keyboard = {
0x87FC => {
'right' => 16,
'down' => 128,
'up' => 192,
'left' => 224,
'backspace' => 224,
},
0x87FD => sub {
my $self = shift;
if ( $self->key_active('return') ) {
# M6502::_write( 0xfc, 13 );
warn "return\n";
return 0;
} elsif ( $self->key_active('left ctrl','right ctrl') ) {
warn "ctrl\n";
return 16;
}
return $keyboard_none;
},
0x87FA => {
'f4' => 16,
'f3' => 128,
'f2' => 192,
'f1' => 224,
},
0x87FB => sub {
my $self = shift;
if ( $self->key_active('space') ) {
warn "space\n";
return 32;
} elsif ( $self->key_active('left shift','right shift') ) {
warn "shift\n";
return 16;
# } elsif ( $self->tape ) {
# warn "has tape!";
# return 0;
}
return $keyboard_none;
},
0x87F6 => {
'6' => 16,
't' => 128,
'y' => 192, # hr: z
'r' => 224,
},
0x87F7 => {
'5' => 32,
'4' => 16,
},
0x87EE => {
'7' => 16,
'u' => 128,
'i' => 192,
'o' => 224,
},
0x87EF => {
'8' => 32,
'9' => 16,
},
0x87DE => {
'1' => 16,
'w' => 128,
'q' => 192,
'e' => 224,
},
0x87DF => {
'2' => 32,
'3' => 16,
},
0x87BE => {
'm' => 16,
'k' => 128,
'j' => 192,
'l' => 224,
},
0x87BF => {
',' => 32, # <
'.' => 16, # >
},
0x877E => {
'z' => 16, # hr:y
's' => 128,
'a' => 192,
'd' => 224,
},
0x877F => {
'x' => 32,
'c' => 16,
},
0x86FE => {
'n' => 16,
'g' => 128,
'h' => 192,
'f' => 224,
},
0x86FF => {
'b' => 32,
'v' => 16,
},
0x85FE => {
'<' => 16, # :
'\\' => 128, # ¾
'\'' => 192, # ę
';' => 224, # č
},
0x85FF => {
'/' => 32,
'f11' => 16, # ^
},
0x83FE => {
'f12' => 16, # ;
'[' => 128, # ¹
']' => 192, # š
'p' => 224,
},
0x83FF => {
'-' => 32,
'0' => 16,
},
};
sub read {
my $self = shift;
my ($addr) = @_;
die "address over 64k: $addr" if ( $addr > 0xffff );
my $byte = $mem[$addr];
confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
# keyboard
if ( defined( $keyboard->{$addr} ) ) {
warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
my $ret = $keyboard_none;
my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
if ( ref($r) eq 'CODE' ) {
$ret = $r->($self);
} else {
foreach my $k ( keys %$r ) {
my $return = 0;
if ( $self->key_active($k) ) {
warn "key '$k' is active\n";
$return ||= $r->{$k};
}
$ret = $return if $return;
}
}
warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
return $ret;
}
if ( $addr == 0x87ff ) {
return $self->read_tape;
}
# $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
return $byte;
}
=head2 write
Write into emory
write( $address, $byte );
=cut
sub write {
my $self = shift;
my ($addr,$byte) = @_;
warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
if ( $addr == 0x8800 ) {
$self->write_tape( $byte );
warn sprintf "sound ignored: %x\n", $byte;
}
if ( $addr > 0xafff ) {
confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
}
$self->render_vram if ( $addr >= 0x6000 && $addr <= 0x7fff );
$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
# $mem[$addr] = $byte;
return;
}
=head1 Architecture specific
=head2 render_vram
Render one frame of video ram
$self->render_vram;
=cut
sub render_vram {
my $self = shift;
# my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
# my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
# my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
my $pixels = pack('C*', map { $flip[$_] } unpack('C*', M6502::mem_peek_region( 0x6000, 0x7fff ) ) );
my $vram = SDL::Surface->new(
-width => 256,
-height => 256,
-depth => 1, # 1 bit per pixel
-pitch => 32, # bytes per line
-from => $pixels,
);
$vram->set_colors( 0, $black, $white );
$self->render_frame( $vram );
}
=head2 cpu_PC
Helper metod to set or get PC for current architecture
=cut
sub cpu_PC {
my ( $self, $addr ) = @_;
if ( defined($addr) ) {
$PC = $addr;
warn sprintf("running from PC %04x\n", $PC);
};
return $PC;
}
=head2 _init_callbacks
Mark memory areas for which we want to get callbacks to perl
=cut
sub _init_callbacks {
my $self = shift;
warn "set calbacks to perl for memory areas...\n";
# don't call for anything
M6502::set_all_callbacks( 0x00 );
# video ram
# M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
# keyboard
M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
# tape
M6502::set_read_callback( 0x87ff );
M6502::set_write_callback( 0x8800 );
my $map = '';
foreach ( 0 .. 0xffff ) {
my $cb = M6502::get_callback( $_ );
$map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
}
warn "callback map:\n$map\n";
}
=head1 SEE ALSO
L<VRac>, L<M6502>, L<Screen>, L<Tape>
=head1 AUTHOR
Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
=head1 ACKNOWLEDGEMENTS
See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
info about this machine (and even hardware implementation from 2007).
=head1 COPYRIGHT & LICENSE
Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Orao
RSS Feed