VRac/M6502/Orao.pm

package Orao;

use warnings;
use strict;

use Carp;
use lib './lib';
#use Time::HiRes qw(time);
use File::Slurp;
use Data::Dump qw/dump/;
use M6502;

use base qw(Class::Accessor M6502 Screen);
__PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';

=head1 SUMMARY

Emulator or Orao 8-bit 6502 machine popular in Croatia

=cut

=head2 init

Start emulator

=cut

our $orao;

sub init {
        my $self = shift;
        warn "Orao calling upstream init\n";
        $self->SUPER::init( $self, @_ );

        warn "staring Orao $Orao::VERSION emulation\n";

        $self->open_screen;
        $self->load_rom({
                0x1000 => 'dump/SCRINV.BIN',
                0xC000 => 'rom/BAS12.ROM',
                0xE000 => 'rom/CRT12.ROM',
        });

        $self->load_oraoemu( 'dump/orao-1.2' );
        $self->load_oraoemu( 'dump/SCRINV.BIN' );
        $PC = 0x1000;

        $orao = $self;

#       $self->prompt( 0x1000 );

        warn "rendering memory map\n";

        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',
        );

        foreach my $i ( 0 .. $#mmap / 3 ) {
                my $o = $i * 3;
                my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
                printf "%04x - %04x - %s\n", $from, $to, $desc;
                for my $a ( $from .. $to ) {
                        $orao->read( $a );
                }
                $self->sync;
        }

        warn "Orao init finished\n";

}

=head2 load_rom

called to init memory and load initial rom images

  $orao->load_rom;

=cut

sub load_rom {
    my ($self, $loaded_files) = @_;

    #my $time_base = time();

        foreach my $addr ( sort keys %$loaded_files ) {
                my $path = $loaded_files->{$addr};
                $self->load_oraoemu( $path, $addr );
        }
}


=head2 load_oraoemu

=cut

sub load_oraoemu {
        my $self = shift;
        my ( $path, $addr ) = @_;

        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;
        } 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) );
                $self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );
                return;
        }
        printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
        return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );
        return $self->write_chunk( $addr, $buff );

        my $chunk;

        my $pos = 0;

        while ( my $long = substr($buff,$pos,4) ) {
                my @b = split(//, $long, 4);
                $chunk .=
                        ( $b[3] || '' ) .
                        ( $b[2] || '' ) .
                        ( $b[1] || '' ) .
                        ( $b[0] || '' );
                $pos += 4;
        }

        $self->write_chunk( $addr, $chunk );

};

=head2 save_dump

  $orao->save_dump( 'filename', $from, $to );

=cut

sub save_dump {
        my $self = shift;

        my ( $path, $from, $to ) = @_;

        $from ||= 0;
        $to ||= 0xffff;

        open(my $fh, '>', $path) || die "can't open $path: $!";
        print $fh $self->read_chunk( $from, $to );
        close($fh);

        my $size = -s $path;
        warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
}

=head2 hexdump

  $orao->hexdump( $address );

=cut

sub hexdump {
        my $self = shift;
        my $a = shift;
        return sprintf(" %04x %s\n", $a,
                join(" ",
                        map {
                                sprintf( "%02x", $_ )
                        } $self->ram( $a, $a+8 )
                )
        );
}

=head2 prompt

  $orao->prompt( $address, $last_command );

=cut

sub prompt {
        my $self = shift;
        my $a = shift;
        my $last = shift;
        print STDERR $self->hexdump( $a ),
                $last ? "[$last] " : '',
                "> ";
        my $in = <STDIN>;
        chomp($in);
        $in ||= $last;
        $last = $in;
        return split(/\s+/, $in) if $in;
}

=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

sub read {
        my $self = shift;
        my ($addr) = @_;
        my $byte = $mem[$addr];
        warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;
        $self->mmap_pixel( $addr, 0, $byte, 0 );
        return $byte;
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
        my $self = shift;
        warn "# Orao::write(",dump(@_),")\n" if $self->debug;
        my ($addr,$byte) = @_;

        if ( $addr >= 0x6000 && $addr < 0x8000 ) {
                $self->vram( $addr - 0x6000 , $byte );
        }

        if ( $addr > 0xafff ) {
                warn sprintf "access to %04x above affff aborting\n", $addr;
                return -1;
        }
        if ( $addr == 0x8800 ) {
                warn sprintf "sound ignored: %x\n", $byte;
        }

        $self->mmap_pixel( $addr, $byte, 0, 0 );

        $mem[$addr] = $byte;
}


=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 BUGS

=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
1	dpavlin	29	package Orao;
2
3			use warnings;
4			use strict;
5
6			use Carp;
7			use lib './lib';
8			#use Time::HiRes qw(time);
9			use File::Slurp;
10	dpavlin	32	use Data::Dump qw/dump/;
11	dpavlin	34	use M6502;
12	dpavlin	29
13	dpavlin	30	use base qw(Class::Accessor M6502 Screen);
14	dpavlin	29	__PACKAGE__->mk_accessors(qw(debug trace run_for mem_dump trace));
15
16			=head1 NAME
17
18			Orao - Orao emulator
19
20			=head1 VERSION
21
22			Version 0.02
23
24			=cut
25
26			our $VERSION = '0.02';
27
28			=head1 SUMMARY
29
30			Emulator or Orao 8-bit 6502 machine popular in Croatia
31
32			=cut
33
34	dpavlin	30	=head2 init
35
36			Start emulator
37
38			=cut
39
40	dpavlin	32	our $orao;
41
42	dpavlin	30	sub init {
43			my $self = shift;
44	dpavlin	34	warn "Orao calling upstream init\n";
45	dpavlin	33	$self->SUPER::init( $self, @_ );
46	dpavlin	30
47	dpavlin	31	warn "staring Orao $Orao::VERSION emulation\n";
48	dpavlin	30
49			$self->open_screen;
50	dpavlin	33	$self->load_rom({
51			0x1000 => 'dump/SCRINV.BIN',
52			0xC000 => 'rom/BAS12.ROM',
53			0xE000 => 'rom/CRT12.ROM',
54			});
55	dpavlin	32
56	dpavlin	35	$self->load_oraoemu( 'dump/orao-1.2' );
57			$self->load_oraoemu( 'dump/SCRINV.BIN' );
58			$PC = 0x1000;
59
60	dpavlin	32	$orao = $self;
61
62	dpavlin	33	# $self->prompt( 0x1000 );
63
64			warn "rendering memory map\n";
65
66			my @mmap = (
67			0x0000, 0x03FF, 'nulti blok',
68			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
69			0x6000, 0x7FFF, 'video RAM',
70			0x8000, 0x9FFF, 'sistemske lokacije',
71			0xA000, 0xAFFF, 'ekstenzija',
72			0xB000, 0xBFFF, 'DOS',
73			0xC000, 0xDFFF, 'BASIC ROM',
74			0xE000, 0xFFFF, 'sistemski ROM',
75			);
76
77			foreach my $i ( 0 .. $#mmap / 3 ) {
78			my $o = $i * 3;
79			my ( $from, $to, $desc ) = @mmap[$o,$o+1,$o+2];
80			printf "%04x - %04x - %s\n", $from, $to, $desc;
81	dpavlin	34	for my $a ( $from .. $to ) {
82			$orao->read( $a );
83			}
84			$self->sync;
85	dpavlin	33	}
86
87	dpavlin	34	warn "Orao init finished\n";
88
89	dpavlin	30	}
90
91	dpavlin	29	=head2 load_rom
92
93			called to init memory and load initial rom images
94
95			$orao->load_rom;
96
97			=cut
98
99			sub load_rom {
100	dpavlin	33	my ($self, $loaded_files) = @_;
101	dpavlin	29
102			#my $time_base = time();
103
104			foreach my $addr ( sort keys %$loaded_files ) {
105			my $path = $loaded_files->{$addr};
106			$self->load_oraoemu( $path, $addr );
107			}
108			}
109
110
111			=head2 load_oraoemu
112
113			=cut
114
115			sub load_oraoemu {
116			my $self = shift;
117			my ( $path, $addr ) = @_;
118
119	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
120	dpavlin	29
121			my $buff = read_file( $path );
122
123			if ( $size == 65538 ) {
124			$addr = 0;
125	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
126	dpavlin	29	$self->write_chunk( $addr, substr($buff,2) );
127			return;
128			} elsif ( $size == 32800 ) {
129			$addr = 0;
130	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
131	dpavlin	29	#$self->write_chunk( $addr, substr($buff,0x20) );
132			$self->poke_code( $addr, map { ord($_) } split(//,substr($buff,0x20)) );
133			return;
134			}
135	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
136	dpavlin	34	return $self->poke_code( $addr, map { ord($_) } split(//,$buff) );
137	dpavlin	29	return $self->write_chunk( $addr, $buff );
138
139			my $chunk;
140
141			my $pos = 0;
142
143			while ( my $long = substr($buff,$pos,4) ) {
144			my @b = split(//, $long, 4);
145			$chunk .=
146			( $b[3] \|\| '' ) .
147			( $b[2] \|\| '' ) .
148			( $b[1] \|\| '' ) .
149			( $b[0] \|\| '' );
150			$pos += 4;
151			}
152
153			$self->write_chunk( $addr, $chunk );
154
155			};
156
157			=head2 save_dump
158
159			$orao->save_dump( 'filename', $from, $to );
160
161			=cut
162
163			sub save_dump {
164			my $self = shift;
165
166			my ( $path, $from, $to ) = @_;
167
168			$from \|\|= 0;
169			$to \|\|= 0xffff;
170
171			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
172			print $fh $self->read_chunk( $from, $to );
173			close($fh);
174
175			my $size = -s $path;
176	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
177	dpavlin	29	}
178
179			=head2 hexdump
180
181			$orao->hexdump( $address );
182
183			=cut
184
185			sub hexdump {
186			my $self = shift;
187			my $a = shift;
188			return sprintf(" %04x %s\n", $a,
189			join(" ",
190			map {
191			sprintf( "%02x", $_ )
192			} $self->ram( $a, $a+8 )
193			)
194			);
195			}
196
197			=head2 prompt
198
199			$orao->prompt( $address, $last_command );
200
201			=cut
202
203			sub prompt {
204			my $self = shift;
205			my $a = shift;
206			my $last = shift;
207	dpavlin	32	print STDERR $self->hexdump( $a ),
208	dpavlin	29	$last ? "[$last] " : '',
209			"> ";
210			my $in = <STDIN>;
211			chomp($in);
212			$in \|\|= $last;
213			$last = $in;
214			return split(/\s+/, $in) if $in;
215			}
216
217	dpavlin	32	=head1 Memory management
218	dpavlin	30
219	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
220			L<Acme::6502> was just too slow to handle it.
221
222			=cut
223
224			=head2 read
225
226			Read from memory
227
228			$byte = read( $address );
229
230			=cut
231
232			sub read {
233	dpavlin	33	my $self = shift;
234	dpavlin	32	my ($addr) = @_;
235			my $byte = $mem[$addr];
236			warn "# Orao::read(",dump(@_),") = ",dump( $byte ),"\n" if $self->debug;
237	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
238	dpavlin	32	return $byte;
239			}
240
241			=head2 write
242
243			Write into emory
244
245			write( $address, $byte );
246
247			=cut
248
249			sub write {
250	dpavlin	33	my $self = shift;
251	dpavlin	32	warn "# Orao::write(",dump(@_),")\n" if $self->debug;
252			my ($addr,$byte) = @_;
253
254			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
255			$self->vram( $addr - 0x6000 , $byte );
256			}
257
258			if ( $addr > 0xafff ) {
259			warn sprintf "access to %04x above affff aborting\n", $addr;
260			return -1;
261			}
262			if ( $addr == 0x8800 ) {
263			warn sprintf "sound ignored: %x\n", $byte;
264			}
265
266	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
267	dpavlin	32
268			$mem[$addr] = $byte;
269			}
270
271
272	dpavlin	29	=head1 AUTHOR
273
274			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
275
276			=head1 BUGS
277
278			=head1 ACKNOWLEDGEMENTS
279
280			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
281			info about this machine (and even hardware implementation from 2007).
282
283			=head1 COPYRIGHT & LICENSE
284
285			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
286
287			This program is free software; you can redistribute it and/or modify it
288			under the same terms as Perl itself.
289
290			=cut
291
292			1; # End of Orao