viewvc.cgi/VRac/Orao.pm

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
1	dpavlin	29	package Orao;
2
3			use warnings;
4			use strict;
5
6	dpavlin	56	use Carp qw/confess/;
7	dpavlin	29	use File::Slurp;
8	dpavlin	32	use Data::Dump qw/dump/;
9	dpavlin	207	use M6502 '0.0.3';
10	dpavlin	165	use Screen;
11	dpavlin	29
12	dpavlin	145	use base qw(Class::Accessor VRac M6502 Screen Prefs Tape Session);
13	dpavlin	124	#__PACKAGE__->mk_accessors(qw());
14	dpavlin	29
15			=head1 NAME
16
17			Orao - Orao emulator
18
19			=head1 VERSION
20
21	dpavlin	145	Version 0.06
22	dpavlin	29
23			=cut
24
25	dpavlin	145	our $VERSION = '0.06';
26	dpavlin	29
27			=head1 SUMMARY
28
29	dpavlin	148	Emulator for Orao 8-bit 6502 machine popular in Croatia (especially schools)
30	dpavlin	29
31			=cut
32
33	dpavlin	95	=head1 FUNCTIONS
34
35	dpavlin	127	=head2 run
36	dpavlin	30
37	dpavlin	127	Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
38	dpavlin	30
39			=cut
40
41	dpavlin	115	our $emu;
42	dpavlin	32
43	dpavlin	127	sub run {
44			my $self = shift;
45	dpavlin	42
46	dpavlin	207	M6502::reset();
47			$self->_init_callbacks;
48
49	dpavlin	34	warn "Orao calling upstream init\n";
50	dpavlin	90	$self->SUPER::init(
51			read => sub { $self->read( @_ ) },
52			write => sub { $self->write( @_ ) },
53			);
54	dpavlin	30
55	dpavlin	56	warn "Orao $Orao::VERSION emulation starting\n";
56	dpavlin	30
57	dpavlin	90	warn "emulating ", $#mem, " bytes of memory\n";
58
59	dpavlin	125	# $self->scale( 2 );
60	dpavlin	179	$self->show_mem( 1 );
61	dpavlin	171	$self->load_session( 'sess/current' );
62	dpavlin	125
63	dpavlin	30	$self->open_screen;
64	dpavlin	33	$self->load_rom({
65	dpavlin	124	# 0x1000 => 'dump/SCRINV.BIN',
66	dpavlin	76	# should be 0x6000, but oraoemu has 2 byte prefix
67	dpavlin	125	# 0x5FFE => '/home/dpavlin/orao/dump/screen.dmp',
68	dpavlin	124	# 0xC000 => 'rom/Orao/BAS12.ROM',
69			# 0xE000 => 'rom/Orao/CRT12.ROM',
70			0xC000 => 'rom/Orao/BAS13.ROM',
71			0xE000 => 'rom/Orao/CRT13.ROM',
72	dpavlin	33	});
73	dpavlin	32
74	dpavlin	73	# $PC = 0xDD11; # BC
75	dpavlin	46	# $PC = 0xC274; # MC
76	dpavlin	35
77	dpavlin	78	$PC = 0xff89;
78
79	dpavlin	115	$emu = $self;
80	dpavlin	32
81	dpavlin	33	# $self->prompt( 0x1000 );
82
83	dpavlin	49	my ( $trace, $debug ) = ( $self->trace, $self->debug );
84	dpavlin	38	$self->trace( 0 );
85	dpavlin	49	$self->debug( 0 );
86	dpavlin	33
87	dpavlin	138	warn "rendering memory\n";
88	dpavlin	209	$self->render_mem( M6502::mem_peek_region(0x0000,0xffff) );
89	dpavlin	73
90	dpavlin	38	if ( $self->show_mem ) {
91	dpavlin	33
92	dpavlin	38	my @mmap = (
93			0x0000, 0x03FF, 'nulti blok',
94			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
95			0x6000, 0x7FFF, 'video RAM',
96			0x8000, 0x9FFF, 'sistemske lokacije',
97			0xA000, 0xAFFF, 'ekstenzija',
98			0xB000, 0xBFFF, 'DOS',
99			0xC000, 0xDFFF, 'BASIC ROM',
100			0xE000, 0xFFFF, 'sistemski ROM',
101			);
102
103	dpavlin	138	print "Orao memory map:";
104
105			while ( @mmap ) {
106			my ( $from, $to, $desc ) = splice(@mmap, 0, 3);
107			printf("%04x-%04x %s\n", $from, $to, $desc);
108			}
109
110	dpavlin	33	}
111	dpavlin	138
112	dpavlin	38	$self->trace( $trace );
113	dpavlin	49	$self->debug( $debug );
114	dpavlin	33
115	dpavlin	82	warn "Orao boot finished",
116	dpavlin	49	$self->trace ? ' trace' : '',
117			$self->debug ? ' debug' : '',
118			"\n";
119	dpavlin	38
120	dpavlin	207	# $self->load_tape( 'tapes/Orao/bdash.tap' );
121			# $self->load_tape( 'tapes/Orao/crtanje.tap' );
122	dpavlin	213	# $self->load_tape( 'tapes/Orao/jjack.tap', 0x168 );
123			$self->load_tape( 'tapes/Orao/muzika.tap', 0x168 );
124	dpavlin	82
125	dpavlin	207	$self->render_vram;
126	dpavlin	110
127	dpavlin	126	$self->loop( sub {
128	dpavlin	127	my $run_for = shift;
129	dpavlin	132	warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
130	dpavlin	127	M6502::exec( $run_for );
131	dpavlin	209	$self->render_vram;
132	dpavlin	213	$self->render_mem( M6502::mem_peek_region(0x0000,0xffff) ) if $self->show_mem;
133	dpavlin	126	});
134	dpavlin	95	};
135
136	dpavlin	127
137	dpavlin	95	=head1 Helper functions
138
139	dpavlin	127	=head2 write_chunk
140
141			Write chunk directly into memory, updateing vram if needed
142
143			$emu->write_chunk( 0x1000, $chunk_data );
144
145	dpavlin	29	=cut
146
147	dpavlin	127	sub write_chunk {
148	dpavlin	46	my $self = shift;
149			my ( $addr, $chunk ) = @_;
150	dpavlin	127	$self->SUPER::write_chunk( $addr, $chunk );
151	dpavlin	46	my $end = $addr + length($chunk);
152			my ( $f, $t ) = ( 0x6000, 0x7fff );
153
154			if ( $end < $f \|\| $addr >= $t ) {
155			warn "skip vram update\n";
156			return;
157			};
158
159			$f = $addr if ( $addr > $f );
160			$t = $end if ( $end < $t );
161
162			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
163	dpavlin	127	$self->render_vram;
164	dpavlin	135	$self->render_mem( @mem );
165	dpavlin	46	}
166
167	dpavlin	94	=head2 load_image
168	dpavlin	61
169			Load binary files, ROM images and Orao Emulator files
170
171	dpavlin	115	$emu->load_image( '/path/to/file', 0x1000 );
172	dpavlin	61
173			Returns true on success.
174
175			=cut
176
177	dpavlin	94	sub load_image {
178	dpavlin	29	my $self = shift;
179			my ( $path, $addr ) = @_;
180
181	dpavlin	61	if ( ! -e $path ) {
182			warn "ERROR: file $path doesn't exist\n";
183			return;
184			}
185
186	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
187	dpavlin	29
188			my $buff = read_file( $path );
189
190			if ( $size == 65538 ) {
191			$addr = 0;
192	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
193	dpavlin	127	$self->write_chunk( $addr, substr($buff,2) );
194	dpavlin	61	return 1;
195	dpavlin	29	} elsif ( $size == 32800 ) {
196			$addr = 0;
197	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
198	dpavlin	127	$self->write_chunk( $addr, substr($buff,0x20) );
199	dpavlin	61	return 1;
200	dpavlin	29	}
201	dpavlin	127
202	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
203	dpavlin	127	$self->write_chunk( $addr, $buff );
204	dpavlin	61	return 1;
205	dpavlin	29	};
206
207
208	dpavlin	32	=head1 Memory management
209	dpavlin	30
210	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
211			L<Acme::6502> was just too slow to handle it.
212
213			=cut
214
215			=head2 read
216
217			Read from memory
218
219			$byte = read( $address );
220
221			=cut
222
223	dpavlin	105	my $keyboard_none = 255;
224
225	dpavlin	98	my $keyboard = {
226			0x87FC => {
227			'right' => 16,
228			'down' => 128,
229			'up' => 192,
230			'left' => 224,
231			'backspace' => 224,
232			},
233	dpavlin	103	0x87FD => sub {
234	dpavlin	171	my $self = shift;
235			if ( $self->key_active('return') ) {
236	dpavlin	179	# M6502::_write( 0xfc, 13 );
237	dpavlin	105	warn "return\n";
238	dpavlin	98	return 0;
239	dpavlin	171	} elsif ( $self->key_active('left ctrl','right ctrl') ) {
240	dpavlin	105	warn "ctrl\n";
241	dpavlin	103	return 16;
242			}
243	dpavlin	105	return $keyboard_none;
244	dpavlin	98	},
245			0x87FA => {
246			'f4' => 16,
247			'f3' => 128,
248			'f2' => 192,
249			'f1' => 224,
250			},
251	dpavlin	103	0x87FB => sub {
252	dpavlin	171	my $self = shift;
253			if ( $self->key_active('space') ) {
254			warn "space\n";
255	dpavlin	103	return 32;
256	dpavlin	171	} elsif ( $self->key_active('left shift','right shift') ) {
257	dpavlin	105	warn "shift\n";
258	dpavlin	103	return 16;
259	dpavlin	110	# } elsif ( $self->tape ) {
260			# warn "has tape!";
261			# return 0;
262	dpavlin	103	}
263	dpavlin	105	return $keyboard_none;
264	dpavlin	98	},
265			0x87F6 => {
266			'6' => 16,
267			't' => 128,
268	dpavlin	105	'y' => 192, # hr: z
269	dpavlin	98	'r' => 224,
270			},
271			0x87F7 => {
272			'5' => 32,
273			'4' => 16,
274			},
275			0x87EE => {
276			'7' => 16,
277			'u' => 128,
278			'i' => 192,
279			'o' => 224,
280			},
281			0x87EF => {
282			'8' => 32,
283			'9' => 16,
284			},
285			0x87DE => {
286			'1' => 16,
287			'w' => 128,
288			'q' => 192,
289			'e' => 224,
290			},
291			0x87DF => {
292			'2' => 32,
293			'3' => 16,
294			},
295			0x87BE => {
296			'm' => 16,
297			'k' => 128,
298			'j' => 192,
299			'l' => 224,
300			},
301			0x87BF => {
302	dpavlin	105	',' => 32, # <
303			'.' => 16, # >
304	dpavlin	98	},
305			0x877E => {
306	dpavlin	105	'z' => 16, # hr:y
307	dpavlin	98	's' => 128,
308			'a' => 192,
309			'd' => 224,
310			},
311			0x877F => {
312			'x' => 32,
313			'c' => 16,
314			},
315			0x86FE => {
316			'n' => 16,
317			'g' => 128,
318			'h' => 192,
319			'f' => 224,
320			},
321			0x86FF => {
322			'b' => 32,
323	dpavlin	102	'v' => 16,
324	dpavlin	98	},
325			0x85FE => {
326	dpavlin	105	'<' => 16, # :
327			'\\' => 128, # ¾
328			'\'' => 192, # æ
329			';' => 224, # è
330	dpavlin	98	},
331			0x85FF => {
332			'/' => 32,
333	dpavlin	105	'f11' => 16, # ^
334	dpavlin	98	},
335			0x83FE => {
336	dpavlin	105	'f12' => 16, # ;
337			'[' => 128, # ¹
338			']' => 192, # ð
339	dpavlin	98	'p' => 224,
340			},
341			0x83FF => {
342			'-' => 32,
343			'0' => 16,
344			},
345			};
346
347	dpavlin	32	sub read {
348	dpavlin	33	my $self = shift;
349	dpavlin	32	my ($addr) = @_;
350	dpavlin	207	die "address over 64k: $addr" if ( $addr > 0xffff );
351	dpavlin	132	my $byte = $mem[$addr];
352	dpavlin	90	confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
353	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
354	dpavlin	78
355			# keyboard
356
357	dpavlin	105	if ( defined( $keyboard->{$addr} ) ) {
358	dpavlin	97	warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
359	dpavlin	171
360			my $ret = $keyboard_none;
361			my $r = $keyboard->{$addr} \|\| confess "no definition for keyboard port found";
362			if ( ref($r) eq 'CODE' ) {
363			$ret = $r->($self);
364			} else {
365			foreach my $k ( keys %$r ) {
366			my $return = 0;
367			if ( $self->key_active($k) ) {
368			warn "key '$k' is active\n";
369			$return \|\|= $r->{$k};
370	dpavlin	98	}
371	dpavlin	171	$ret = $return if $return;
372	dpavlin	98	}
373			}
374	dpavlin	171	warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
375			return $ret;
376	dpavlin	78	}
377
378	dpavlin	109	if ( $addr == 0x87ff ) {
379			return $self->read_tape;
380			}
381
382	dpavlin	213	# $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
383	dpavlin	32	return $byte;
384			}
385
386			=head2 write
387
388			Write into emory
389
390			write( $address, $byte );
391
392			=cut
393
394			sub write {
395	dpavlin	33	my $self = shift;
396	dpavlin	32	my ($addr,$byte) = @_;
397	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
398	dpavlin	32
399			if ( $addr == 0x8800 ) {
400	dpavlin	145	$self->write_tape( $byte );
401	dpavlin	32	warn sprintf "sound ignored: %x\n", $byte;
402			}
403
404	dpavlin	52	if ( $addr > 0xafff ) {
405	dpavlin	90	confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
406	dpavlin	52	}
407
408	dpavlin	207	$self->render_vram if ( $addr >= 0x6000 && $addr <= 0x7fff );
409
410	dpavlin	135	$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
411	dpavlin	209	# $mem[$addr] = $byte;
412	dpavlin	36	return;
413	dpavlin	32	}
414
415	dpavlin	138	=head1 Architecture specific
416
417	dpavlin	125	=head2 render_vram
418
419			Render one frame of video ram
420
421	dpavlin	126	$self->render_vram;
422	dpavlin	125
423			=cut
424
425			sub render_vram {
426			my $self = shift;
427
428	dpavlin	209	# my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
429			# my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
430	dpavlin	213	# my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
431			my $pixels = pack('C', map { $flip[$_] } unpack('C', M6502::mem_peek_region( 0x6000, 0x7fff ) ) );
432	dpavlin	125
433			my $vram = SDL::Surface->new(
434			-width => 256,
435			-height => 256,
436			-depth => 1, # 1 bit per pixel
437			-pitch => 32, # bytes per line
438			-from => $pixels,
439			);
440			$vram->set_colors( 0, $black, $white );
441
442			$self->render_frame( $vram );
443			}
444
445	dpavlin	127	=head2 cpu_PC
446
447	dpavlin	138	Helper metod to set or get PC for current architecture
448
449	dpavlin	127	=cut
450
451			sub cpu_PC {
452			my ( $self, $addr ) = @_;
453			if ( defined($addr) ) {
454			$PC = $addr;
455			warn sprintf("running from PC %04x\n", $PC);
456			};
457			return $PC;
458			}
459
460	dpavlin	207
461			=head2 _init_callbacks
462
463			Mark memory areas for which we want to get callbacks to perl
464
465			=cut
466
467			sub _init_callbacks {
468			my $self = shift;
469			warn "set calbacks to perl for memory areas...\n";
470
471			# don't call for anything
472			M6502::set_all_callbacks( 0x00 );
473
474			# video ram
475	dpavlin	209	# M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
476	dpavlin	207	# keyboard
477			M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
478			# tape
479			M6502::set_read_callback( 0x87ff );
480			M6502::set_write_callback( 0x8800 );
481
482			my $map = '';
483			foreach ( 0 .. 0xffff ) {
484			my $cb = M6502::get_callback( $_ );
485			$map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
486			}
487			warn "callback map:\n$map\n";
488			}
489
490	dpavlin	145	=head1 SEE ALSO
491
492			L<VRac>, L<M6502>, L<Screen>, L<Tape>
493
494	dpavlin	29	=head1 AUTHOR
495
496			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
497
498			=head1 ACKNOWLEDGEMENTS
499
500			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
501			info about this machine (and even hardware implementation from 2007).
502
503			=head1 COPYRIGHT & LICENSE
504
505			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
506
507			This program is free software; you can redistribute it and/or modify it
508			under the same terms as Perl itself.
509
510			=cut
511
512			1; # End of Orao