viewvc.cgi/VRac/Galaksija.pm

package Galaksija;

use warnings;
use strict;

use Carp qw/confess/;
use File::Slurp;
use Data::Dump qw/dump/;
use Z80; # import

use base qw(Class::Accessor VRac Z80 Screen Prefs Session);
__PACKAGE__->mk_accessors(qw(booted));

=head1 NAME

Galaksija - Galaksija emulator

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SUMMARY

Emulator of Galaksija 8-bit Z80 machine popular in former Yugoslavia

=cut

=head1 FUNCTIONS

=head2 run

=cut

our $emu;

sub run {
        my $self = shift;

        warn "Galaksija $Galaksija::VERSION emulation starting\n";

        $self->show_mem( 1 );
        #$self->trace( 1 );

        $self->SUPER::init(
                read => sub { $self->read( @_ ) },
                write => sub { $self->write( @_ ) },
        );

        for my $a ( 0x1000 .. 0x2000 ) {
                $mem[$a] = 0xff;
        }

        $self->open_screen;
        $self->load_rom({
                0x0000, 'rom/Galaksija/ROM1.BIN',
                0x2000, 'rom/Galaksija/ROM2.BIN',
#               0xE000, 'rom/Galaksija/GAL_PLUS.BIN',
        });

        # keyboard
        $mem[$_] = 0xff foreach ( 0x2000 .. 0x2800 );

        # display
        $mem[$_] = 0x20 foreach ( 0x2800 .. 0x2a00 );

        # 6116-ice
        $mem[$_] = 0    foreach ( 0x2a00 .. 0x4000 );

        $emu = $self;

        my ( $trace, $debug ) = ( $self->trace, $self->debug );
        $self->trace( 0 );
        $self->debug( 0 );

        warn "rendering memory\n";
        $self->render_mem( @mem );

        #$self->sync;
        $self->trace( $trace );
        $self->debug( $debug );

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

        Z80::reset();

        my $hor_pos = 0;

        $self->loop( sub {
                Z80::exec( $_[0] );
                if ( $hor_pos != $mem[ 0x2ba8 ] ) {
                        warn "scroll 0x2ba8", $self->hexdump( 0x2ba8 );
                        $hor_pos = $mem[ 0x2ba8 ];
                }
                $self->render_vram;
        });

}


=head1 Memory management

=cut

=head2 read

Read from memory

  $byte = read( $address );

=cut

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("# Galaksija::read(%04x) = %02x\n", $addr, $byte) if $self->trace;

        $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("# Galaksija::write(%04x,%02x)\n", $addr, $byte) if $self->trace;

        return if ( $addr > 0x4000 );

        $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
        $mem[$addr] = $byte;
        return;
}

=head1 Architecture specific

=cut

my @keymap = (
        'a' .. 'z',
        qw/up down left right space/,
        '0' .. '9',
        ':', '"', ',', '=', '.', '/', 'enter', 'tab',
        'left alt', 'delete', 'scroll lock', 'left shift'
);

my $remap;
my $o = 1;

foreach my $key ( @keymap ) {
        $remap->{$key} = $o;
        $o++;
}

=head2 key_down

=cut

sub key_down {
        my ( $self, $key ) = @_;
        warn "key down: $key ", $remap->{$key};
        $self->write( 0x2000 + $remap->{$key}, 0xfe );
}

=head2 key_up

=cut

sub key_up {
        my ( $self, $key ) = @_;
        warn "key up: $key ", $remap->{$key};
        $self->write( 0x2000 + $remap->{$key}, 0xff );
}

=head2 render_vram

Simple hex dumper of text buffer

=cut

my $last_dump = '';

sub render_vram {
        my $self = shift;

        my $addr = 0x2800;

        my $dump;

        for my $y ( 0 .. 15 ) {
#               $dump .= sprintf "%2d: %s\n",$y, join('', map { sprintf("%02x ",$_) } @mem[ $addr .. $addr+31 ] );
                $dump .= sprintf "%2d: %s\n",$y, join('', map { chr( $_ ) } @mem[ $addr .. $addr+31 ] );
                $addr += 32;
        }

        if ( $mem[ 0x2bb0 ] ) {
                warn "scroll", $self->hexdump( 0x2bb0 );
        }

        if ( $dump ne $last_dump ) {
                print $dump;
                $last_dump = $dump;
        }
}

=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<Screen>, L<Z80>

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 BUGS

Galaksija Plus isn't emulated. I don't have additional rom, but I would
B<love> to have support for this machine. So if you have ROM for Galaksija
Plus, get in touch!

=head1 ACKNOWLEDGEMENTS

Based on Galaxy emulator L<http://emulator.galaksija.org/> for Windows which
is in turn based on DOS version by Miodrag Jevremoviæ
L<http://solair.eunet.yu/~jovkovic/galaxy/>.

=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 Galaksija
1	dpavlin	130	package Galaksija;
2
3			use warnings;
4			use strict;
5
6			use Carp qw/confess/;
7			use File::Slurp;
8			use Data::Dump qw/dump/;
9	dpavlin	131	use Z80; # import
10	dpavlin	130
11	dpavlin	163	use base qw(Class::Accessor VRac Z80 Screen Prefs Session);
12	dpavlin	130	__PACKAGE__->mk_accessors(qw(booted));
13
14			=head1 NAME
15
16			Galaksija - Galaksija emulator
17
18			=head1 VERSION
19
20	dpavlin	163	Version 0.01
21	dpavlin	130
22			=cut
23
24	dpavlin	163	our $VERSION = '0.01';
25	dpavlin	130
26			=head1 SUMMARY
27
28			Emulator of Galaksija 8-bit Z80 machine popular in former Yugoslavia
29
30			=cut
31
32			=head1 FUNCTIONS
33
34			=head2 run
35
36			=cut
37
38			our $emu;
39
40			sub run {
41			my $self = shift;
42	dpavlin	131
43			warn "Galaksija $Galaksija::VERSION emulation starting\n";
44
45			$self->show_mem( 1 );
46	dpavlin	137	#$self->trace( 1 );
47	dpavlin	131
48	dpavlin	130	$self->SUPER::init(
49			read => sub { $self->read( @_ ) },
50			write => sub { $self->write( @_ ) },
51			);
52
53			for my $a ( 0x1000 .. 0x2000 ) {
54			$mem[$a] = 0xff;
55			}
56
57			$self->open_screen;
58			$self->load_rom({
59			0x0000, 'rom/Galaksija/ROM1.BIN',
60			0x2000, 'rom/Galaksija/ROM2.BIN',
61			# 0xE000, 'rom/Galaksija/GAL_PLUS.BIN',
62			});
63
64			# keyboard
65			$mem[$_] = 0xff foreach ( 0x2000 .. 0x2800 );
66
67			# display
68	dpavlin	139	$mem[$_] = 0x20 foreach ( 0x2800 .. 0x2a00 );
69	dpavlin	130
70			# 6116-ice
71			$mem[$_] = 0 foreach ( 0x2a00 .. 0x4000 );
72
73			$emu = $self;
74
75			my ( $trace, $debug ) = ( $self->trace, $self->debug );
76			$self->trace( 0 );
77			$self->debug( 0 );
78
79	dpavlin	137	warn "rendering memory\n";
80			$self->render_mem( @mem );
81	dpavlin	130
82			#$self->sync;
83			$self->trace( $trace );
84			$self->debug( $debug );
85
86			warn "Galaksija boot finished",
87			$self->trace ? ' trace' : '',
88			$self->debug ? ' debug' : '',
89			"\n";
90
91			Z80::reset();
92
93	dpavlin	140	my $hor_pos = 0;
94
95	dpavlin	130	$self->loop( sub {
96			Z80::exec( $_[0] );
97	dpavlin	140	if ( $hor_pos != $mem[ 0x2ba8 ] ) {
98			warn "scroll 0x2ba8", $self->hexdump( 0x2ba8 );
99			$hor_pos = $mem[ 0x2ba8 ];
100			}
101	dpavlin	137	$self->render_vram;
102	dpavlin	130	});
103
104			}
105
106
107			=head1 Memory management
108
109			=cut
110
111			=head2 read
112
113			Read from memory
114
115			$byte = read( $address );
116
117			=cut
118
119			sub read {
120			my $self = shift;
121			my ($addr) = @_;
122			my $byte = $mem[$addr];
123			confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
124			warn sprintf("# Galaksija::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
125
126	dpavlin	137	$self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
127	dpavlin	130	return $byte;
128			}
129
130			=head2 write
131
132			Write into emory
133
134			write( $address, $byte );
135
136			=cut
137
138			sub write {
139			my $self = shift;
140			my ($addr,$byte) = @_;
141			warn sprintf("# Galaksija::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
142
143	dpavlin	140	return if ( $addr > 0x4000 );
144
145	dpavlin	137	$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
146	dpavlin	130	$mem[$addr] = $byte;
147			return;
148			}
149
150	dpavlin	137	=head1 Architecture specific
151
152	dpavlin	163	=cut
153
154			my @keymap = (
155			'a' .. 'z',
156			qw/up down left right space/,
157			'0' .. '9',
158			':', '"', ',', '=', '.', '/', 'enter', 'tab',
159			'left alt', 'delete', 'scroll lock', 'left shift'
160			);
161
162			my $remap;
163			my $o = 1;
164
165			foreach my $key ( @keymap ) {
166			$remap->{$key} = $o;
167			$o++;
168			}
169
170			=head2 key_down
171
172			=cut
173
174			sub key_down {
175			my ( $self, $key ) = @_;
176			warn "key down: $key ", $remap->{$key};
177			$self->write( 0x2000 + $remap->{$key}, 0xfe );
178			}
179
180			=head2 key_up
181
182			=cut
183
184			sub key_up {
185			my ( $self, $key ) = @_;
186			warn "key up: $key ", $remap->{$key};
187			$self->write( 0x2000 + $remap->{$key}, 0xff );
188			}
189
190	dpavlin	137	=head2 render_vram
191
192			Simple hex dumper of text buffer
193
194			=cut
195
196	dpavlin	139	my $last_dump = '';
197
198	dpavlin	137	sub render_vram {
199			my $self = shift;
200
201			my $addr = 0x2800;
202
203	dpavlin	139	my $dump;
204
205	dpavlin	137	for my $y ( 0 .. 15 ) {
206	dpavlin	140	# $dump .= sprintf "%2d: %s\n",$y, join('', map { sprintf("%02x ",$_) } @mem[ $addr .. $addr+31 ] );
207			$dump .= sprintf "%2d: %s\n",$y, join('', map { chr( $_ ) } @mem[ $addr .. $addr+31 ] );
208	dpavlin	137	$addr += 32;
209			}
210	dpavlin	140
211			if ( $mem[ 0x2bb0 ] ) {
212			warn "scroll", $self->hexdump( 0x2bb0 );
213			}
214
215	dpavlin	139	if ( $dump ne $last_dump ) {
216			print $dump;
217			$last_dump = $dump;
218			}
219	dpavlin	137	}
220
221	dpavlin	131	=head2 cpu_PC
222
223			Helper metod to set or get PC for current architecture
224
225			=cut
226
227			sub cpu_PC {
228			my ( $self, $addr ) = @_;
229			if ( defined($addr) ) {
230			$PC = $addr;
231			warn sprintf("running from PC %04x\n", $PC);
232			};
233			return $PC;
234			}
235
236	dpavlin	137	=head1 SEE ALSO
237
238			L<VRac>, L<Screen>, L<Z80>
239
240	dpavlin	130	=head1 AUTHOR
241
242			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
243
244			=head1 BUGS
245
246	dpavlin	148	Galaksija Plus isn't emulated. I don't have additional rom, but I would
247			B<love> to have support for this machine. So if you have ROM for Galaksija
248			Plus, get in touch!
249
250	dpavlin	130	=head1 ACKNOWLEDGEMENTS
251
252	dpavlin	148	Based on Galaxy emulator L<http://emulator.galaksija.org/> for Windows which
253			is in turn based on DOS version by Miodrag Jevremoviæ
254			L<http://solair.eunet.yu/~jovkovic/galaxy/>.
255	dpavlin	130
256			=head1 COPYRIGHT & LICENSE
257
258			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
259
260			This program is free software; you can redistribute it and/or modify it
261			under the same terms as Perl itself.
262
263			=cut
264
265			1; # End of Galaksija