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

        $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;
        });
};


=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 $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			$self->load_tape( 'tapes/Orao/jjack.tap' );
123	dpavlin	82
124	dpavlin	207	$self->render_vram;
125	dpavlin	110
126	dpavlin	126	$self->loop( sub {
127	dpavlin	127	my $run_for = shift;
128	dpavlin	132	warn sprintf("about to exec from PC %04x for %d cycles\n", $PC, $run_for) if $self->trace;
129	dpavlin	127	M6502::exec( $run_for );
130	dpavlin	209	$self->render_vram;
131	dpavlin	126	});
132	dpavlin	95	};
133
134	dpavlin	127
135	dpavlin	95	=head1 Helper functions
136
137	dpavlin	127	=head2 write_chunk
138
139			Write chunk directly into memory, updateing vram if needed
140
141			$emu->write_chunk( 0x1000, $chunk_data );
142
143	dpavlin	29	=cut
144
145	dpavlin	127	sub write_chunk {
146	dpavlin	46	my $self = shift;
147			my ( $addr, $chunk ) = @_;
148	dpavlin	127	$self->SUPER::write_chunk( $addr, $chunk );
149	dpavlin	46	my $end = $addr + length($chunk);
150			my ( $f, $t ) = ( 0x6000, 0x7fff );
151
152			if ( $end < $f \|\| $addr >= $t ) {
153			warn "skip vram update\n";
154			return;
155			};
156
157			$f = $addr if ( $addr > $f );
158			$t = $end if ( $end < $t );
159
160			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
161	dpavlin	127	$self->render_vram;
162	dpavlin	135	$self->render_mem( @mem );
163	dpavlin	46	}
164
165	dpavlin	94	=head2 load_image
166	dpavlin	61
167			Load binary files, ROM images and Orao Emulator files
168
169	dpavlin	115	$emu->load_image( '/path/to/file', 0x1000 );
170	dpavlin	61
171			Returns true on success.
172
173			=cut
174
175	dpavlin	94	sub load_image {
176	dpavlin	29	my $self = shift;
177			my ( $path, $addr ) = @_;
178
179	dpavlin	61	if ( ! -e $path ) {
180			warn "ERROR: file $path doesn't exist\n";
181			return;
182			}
183
184	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
185	dpavlin	29
186			my $buff = read_file( $path );
187
188			if ( $size == 65538 ) {
189			$addr = 0;
190	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
191	dpavlin	127	$self->write_chunk( $addr, substr($buff,2) );
192	dpavlin	61	return 1;
193	dpavlin	29	} elsif ( $size == 32800 ) {
194			$addr = 0;
195	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
196	dpavlin	127	$self->write_chunk( $addr, substr($buff,0x20) );
197	dpavlin	61	return 1;
198	dpavlin	29	}
199	dpavlin	127
200	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
201	dpavlin	127	$self->write_chunk( $addr, $buff );
202	dpavlin	61	return 1;
203	dpavlin	29	};
204
205
206	dpavlin	32	=head1 Memory management
207	dpavlin	30
208	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
209			L<Acme::6502> was just too slow to handle it.
210
211			=cut
212
213			=head2 read
214
215			Read from memory
216
217			$byte = read( $address );
218
219			=cut
220
221	dpavlin	105	my $keyboard_none = 255;
222
223	dpavlin	98	my $keyboard = {
224			0x87FC => {
225			'right' => 16,
226			'down' => 128,
227			'up' => 192,
228			'left' => 224,
229			'backspace' => 224,
230			},
231	dpavlin	103	0x87FD => sub {
232	dpavlin	171	my $self = shift;
233			if ( $self->key_active('return') ) {
234	dpavlin	179	# M6502::_write( 0xfc, 13 );
235	dpavlin	105	warn "return\n";
236	dpavlin	98	return 0;
237	dpavlin	171	} elsif ( $self->key_active('left ctrl','right ctrl') ) {
238	dpavlin	105	warn "ctrl\n";
239	dpavlin	103	return 16;
240			}
241	dpavlin	105	return $keyboard_none;
242	dpavlin	98	},
243			0x87FA => {
244			'f4' => 16,
245			'f3' => 128,
246			'f2' => 192,
247			'f1' => 224,
248			},
249	dpavlin	103	0x87FB => sub {
250	dpavlin	171	my $self = shift;
251			if ( $self->key_active('space') ) {
252			warn "space\n";
253	dpavlin	103	return 32;
254	dpavlin	171	} elsif ( $self->key_active('left shift','right shift') ) {
255	dpavlin	105	warn "shift\n";
256	dpavlin	103	return 16;
257	dpavlin	110	# } elsif ( $self->tape ) {
258			# warn "has tape!";
259			# return 0;
260	dpavlin	103	}
261	dpavlin	105	return $keyboard_none;
262	dpavlin	98	},
263			0x87F6 => {
264			'6' => 16,
265			't' => 128,
266	dpavlin	105	'y' => 192, # hr: z
267	dpavlin	98	'r' => 224,
268			},
269			0x87F7 => {
270			'5' => 32,
271			'4' => 16,
272			},
273			0x87EE => {
274			'7' => 16,
275			'u' => 128,
276			'i' => 192,
277			'o' => 224,
278			},
279			0x87EF => {
280			'8' => 32,
281			'9' => 16,
282			},
283			0x87DE => {
284			'1' => 16,
285			'w' => 128,
286			'q' => 192,
287			'e' => 224,
288			},
289			0x87DF => {
290			'2' => 32,
291			'3' => 16,
292			},
293			0x87BE => {
294			'm' => 16,
295			'k' => 128,
296			'j' => 192,
297			'l' => 224,
298			},
299			0x87BF => {
300	dpavlin	105	',' => 32, # <
301			'.' => 16, # >
302	dpavlin	98	},
303			0x877E => {
304	dpavlin	105	'z' => 16, # hr:y
305	dpavlin	98	's' => 128,
306			'a' => 192,
307			'd' => 224,
308			},
309			0x877F => {
310			'x' => 32,
311			'c' => 16,
312			},
313			0x86FE => {
314			'n' => 16,
315			'g' => 128,
316			'h' => 192,
317			'f' => 224,
318			},
319			0x86FF => {
320			'b' => 32,
321	dpavlin	102	'v' => 16,
322	dpavlin	98	},
323			0x85FE => {
324	dpavlin	105	'<' => 16, # :
325			'\\' => 128, # ¾
326			'\'' => 192, # æ
327			';' => 224, # è
328	dpavlin	98	},
329			0x85FF => {
330			'/' => 32,
331	dpavlin	105	'f11' => 16, # ^
332	dpavlin	98	},
333			0x83FE => {
334	dpavlin	105	'f12' => 16, # ;
335			'[' => 128, # ¹
336			']' => 192, # ð
337	dpavlin	98	'p' => 224,
338			},
339			0x83FF => {
340			'-' => 32,
341			'0' => 16,
342			},
343			};
344
345	dpavlin	32	sub read {
346	dpavlin	33	my $self = shift;
347	dpavlin	32	my ($addr) = @_;
348	dpavlin	207	die "address over 64k: $addr" if ( $addr > 0xffff );
349	dpavlin	132	my $byte = $mem[$addr];
350	dpavlin	90	confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
351	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
352	dpavlin	78
353			# keyboard
354
355	dpavlin	105	if ( defined( $keyboard->{$addr} ) ) {
356	dpavlin	97	warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
357	dpavlin	171
358			my $ret = $keyboard_none;
359			my $r = $keyboard->{$addr} \|\| confess "no definition for keyboard port found";
360			if ( ref($r) eq 'CODE' ) {
361			$ret = $r->($self);
362			} else {
363			foreach my $k ( keys %$r ) {
364			my $return = 0;
365			if ( $self->key_active($k) ) {
366			warn "key '$k' is active\n";
367			$return \|\|= $r->{$k};
368	dpavlin	98	}
369	dpavlin	171	$ret = $return if $return;
370	dpavlin	98	}
371			}
372	dpavlin	171	warn sprintf("keyboard port: %04x code: %d\n",$addr,$ret) if ( $ret != $keyboard_none );
373			return $ret;
374	dpavlin	78	}
375
376	dpavlin	109	if ( $addr == 0x87ff ) {
377			return $self->read_tape;
378			}
379
380	dpavlin	135	$self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
381	dpavlin	32	return $byte;
382			}
383
384			=head2 write
385
386			Write into emory
387
388			write( $address, $byte );
389
390			=cut
391
392			sub write {
393	dpavlin	33	my $self = shift;
394	dpavlin	32	my ($addr,$byte) = @_;
395	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
396	dpavlin	32
397			if ( $addr == 0x8800 ) {
398	dpavlin	145	$self->write_tape( $byte );
399	dpavlin	32	warn sprintf "sound ignored: %x\n", $byte;
400			}
401
402	dpavlin	52	if ( $addr > 0xafff ) {
403	dpavlin	90	confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
404	dpavlin	52	}
405
406	dpavlin	207	$self->render_vram if ( $addr >= 0x6000 && $addr <= 0x7fff );
407
408	dpavlin	135	$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
409	dpavlin	209	# $mem[$addr] = $byte;
410	dpavlin	36	return;
411	dpavlin	32	}
412
413	dpavlin	138	=head1 Architecture specific
414
415	dpavlin	125	=head2 render_vram
416
417			Render one frame of video ram
418
419	dpavlin	126	$self->render_vram;
420	dpavlin	125
421			=cut
422
423			sub render_vram {
424			my $self = shift;
425
426	dpavlin	209	# my $pixels = pack("C*", map { $flip[$_] } @mem[ 0x6000 .. 0x7fff ]);
427			# my $pixels = pack("C*", map { $flip[$_] } $self->ram( 0x6000, 0x7fff ));
428			my $pixels = M6502::mem_peek_region( 0x6000, 0x7fff );
429	dpavlin	125
430			my $vram = SDL::Surface->new(
431			-width => 256,
432			-height => 256,
433			-depth => 1, # 1 bit per pixel
434			-pitch => 32, # bytes per line
435			-from => $pixels,
436			);
437			$vram->set_colors( 0, $black, $white );
438
439			$self->render_frame( $vram );
440			}
441
442	dpavlin	127	=head2 cpu_PC
443
444	dpavlin	138	Helper metod to set or get PC for current architecture
445
446	dpavlin	127	=cut
447
448			sub cpu_PC {
449			my ( $self, $addr ) = @_;
450			if ( defined($addr) ) {
451			$PC = $addr;
452			warn sprintf("running from PC %04x\n", $PC);
453			};
454			return $PC;
455			}
456
457	dpavlin	207
458			=head2 _init_callbacks
459
460			Mark memory areas for which we want to get callbacks to perl
461
462			=cut
463
464			sub _init_callbacks {
465			my $self = shift;
466			warn "set calbacks to perl for memory areas...\n";
467
468			# don't call for anything
469			M6502::set_all_callbacks( 0x00 );
470
471			# video ram
472	dpavlin	209	# M6502::set_write_callback( $_ ) foreach ( 0x6000 .. 0x7fff );
473	dpavlin	207	# keyboard
474			M6502::set_read_callback( $_ ) foreach ( keys %$keyboard );
475			# tape
476			M6502::set_read_callback( 0x87ff );
477			M6502::set_write_callback( 0x8800 );
478
479			my $map = '';
480			foreach ( 0 .. 0xffff ) {
481			my $cb = M6502::get_callback( $_ );
482			$map .= sprintf( "%04x: %02x\n", $_, $cb ) if $cb;
483			}
484			warn "callback map:\n$map\n";
485			}
486
487	dpavlin	145	=head1 SEE ALSO
488
489			L<VRac>, L<M6502>, L<Screen>, L<Tape>
490
491	dpavlin	29	=head1 AUTHOR
492
493			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
494
495			=head1 ACKNOWLEDGEMENTS
496
497			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
498			info about this machine (and even hardware implementation from 2007).
499
500			=head1 COPYRIGHT & LICENSE
501
502			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
503
504			This program is free software; you can redistribute it and/or modify it
505			under the same terms as Perl itself.
506
507			=cut
508
509			1; # End of Orao