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; # import @mem $PC and friends
use Screen qw/$white $black/;

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 or Orao 8-bit 6502 machine popular in Croatia

=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;

        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->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( @mem );

        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";

        M6502::reset();

#       $self->load_tape( '../oraoigre/bdash.tap' );

        $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, $key ) = @_;
                if ( $key eq 'return' ) {
                        M6502::_write( 0xfc, 13 );
                        warn "return\n";
                        return 0;
                } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
                        warn "ctrl\n";
                        return 16;
                }
                return $keyboard_none;
        },
        0x87FA => {
                'f4' => 16,
                'f3' => 128,
                'f2' => 192,
                'f1' => 224,
        },
        0x87FB => sub {
                my ( $self, $key ) = @_;
                if ( $key eq 'space' ) {
                        return 32;
                } elsif ( $self->key_down( 'left shift' ) || $self->key_down( '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) = @_;
        return 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 $key = $self->key_pressed;
                if ( defined($key) ) {
                        my $ret = $keyboard_none;
                        my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
                        if ( ref($r) eq 'CODE' ) {
                                $ret = $r->($self, $key);
                        } elsif ( defined($r->{$key}) ) {
                                $ret = $r->{$key};
                                if ( ref($ret) eq 'CODE' ) {
                                        $ret = $ret->($self);
                                }
                        } else {
                                warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
                        }
                        warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
                        return $ret;
                }
                return $keyboard_none;
        }

        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->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

my @flip;

foreach my $i ( 0 .. 255 ) {
        my $t = 0;
        $i & 0b00000001 and $t = $t | 0b10000000;
        $i & 0b00000010 and $t = $t | 0b01000000;
        $i & 0b00000100 and $t = $t | 0b00100000;
        $i & 0b00001000 and $t = $t | 0b00010000;
        $i & 0b00010000 and $t = $t | 0b00001000;
        $i & 0b00100000 and $t = $t | 0b00000100;
        $i & 0b01000000 and $t = $t | 0b00000010;
        $i & 0b10000000 and $t = $t | 0b00000001;
        #warn "$i = $t\n";
        $flip[$i] = $t;
}


sub render_vram {
        my $self = shift;

        my $pixels = pack("C*", map { $flip[$_] } @mem[ 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;
}

=head1 SEE ALSO

L<VRac>, L<M6502>, L<Screen>, L<Tape>

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