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);
#__PACKAGE__->mk_accessors(qw());

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.05

=cut

our $VERSION = '0.05';

=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->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 video memory\n";
        $self->render_vram;

        if ( $self->show_mem ) {

                warn "rendering memory map\n";

                $self->render_mem( @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',
                );

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

=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

=cut

sub cpu_PC {
        my ( $self, $addr ) = @_;
        if ( defined($addr) ) {
                $PC = $addr;
                warn sprintf("running from PC %04x\n", $PC);
        };
        return $PC;
}

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