viewvc.cgi/VRac/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', 0x1000 );
        $PC = 0x1000;

        $orao = $self;

#       $self->prompt( 0x1000 );

        my $trace = $self->trace;
        $self->trace( 0 );

        if ( $self->show_mem ) {

                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 ) {
                                if ( $a >= 0x6000 && $a < 0x8000 ) {
                                        my $b = $self->read( $a );
                                        $self->vram( $a - 0x6000, $b );
                                } else {
                                        $self->read( $a );
                                }
                        }
                }

        } else {

                warn "rendering video memory\n";
                for my $a ( 0x6000 .. 0x7fff ) {
                        $self->vram( $a - 0x6000, $mem[$a] );
                }
        
        }
        $self->sync;
        $self->trace( $trace );

        #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );

        warn "Orao init finished", $self->trace ? ' trace on' : '', "\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 sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
        $self->mmap_pixel( $addr, 0, $byte, 0 );
        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 >= 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;
        return;
}


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