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

Start emulator, open L<Screen>, load initial ROM images, and render memory

  my $emu = Orao->new({});
  $emu->boot;

=cut

our $emu;

select(STDERR); $| = 1;

sub boot {
        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( @mem[ 0x6000 .. 0x7fff ] );

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

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

        warn "Orao boot finished",
                $self->trace ? ' trace' : '',
                $self->debug ? ' debug' : '',
                "\n";

        M6502::reset();

        $self->booted( 1 );
}

=head2 run

Run interactive emulation loop

  $emu->run;

=cut

sub run {
        my $self = shift;

        $self->boot if ( ! $self->booted );

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

        $self->loop;
};

=head1 Helper functions

=cut

# write chunk directly into memory, updateing vram if needed
sub _write_chunk {
        my $self = shift;
        my ( $addr, $chunk ) = @_;
        $self->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( @mem[ 0x6000 .. 0x7fff ] );
        $self->render_mem( @mem ) if $self->show_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;

        my $chunk;

        my $pos = 0;

        while ( my $long = substr($buff,$pos,4) ) {
                my @b = split(//, $long, 4);
                $chunk .=
                        ( $b[3] || '' ) .
                        ( $b[2] || '' ) .
                        ( $b[1] || '' ) .
                        ( $b[0] || '' );
                $pos += 4;
        }

        $self->_write_chunk( $addr, $chunk );

        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) = @_;
        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 );
        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 );

        $mem[$addr] = $byte;
        return;
}

=head2 render_vram

Render one frame of video ram

  $self->render_vram( @video_memory );

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

        confess "no data?" unless (@_);
        confess "screen size not 256*256/8 but ",($#_+1) unless (($#_+1) == (256*256/8));

        return unless $self->booted;

        my $pixels = pack("C*", map { $flip[$_] } @_);

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

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