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;
use Screen;
use Time::HiRes qw/time/;

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',
                0x1000, '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 {
                my $run_for = shift;
                Z80::exec( $run_for );
                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',
        ':', '"', ',', '=', '.', '/', 'return', 'tab',
        'left alt', 'backspace', '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 "registered key down: $key ", $remap->{$key};
        $self->write( 0x2000 + $remap->{$key}, 0xfe );
}

=head2 key_up

=cut

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

=head2 render_vram

Render characters as graphic

=cut

my $char_rom = 'rom/Galaksija/CHRGEN.BIN';

my @chars = map { ord($_) } split(//, read_file( $char_rom ));
warn "loaded ", $#chars, " characters\n";

my @char2pos;

# maken from mess/video/galaxy.c
foreach my $char ( 0 .. 255 ) {
        my $c = $char;
        if ( ( $c > 63 && $c < 96 ) || ( $c > 127 && $c < 192 ) ) {
                $c -= 64;
        } elsif ( $c > 191 ) {
                $c -= 128;
        }
        $char2pos[ $char ] = ( $c & 0x7f );
}

warn dump( @char2pos );

sub render_vram {
        my $self = shift;

        my $t = time();

        my $addr = 0x2800;

        my @pixels = ("\x00") x ( 32 * 16 * 13 );
        my $a = 0;

        for my $y ( 0 .. 15 ) {
                for my $x ( 0 .. 31 ) {
                        my $c = $mem[ $addr++ ];
                        $c = $char2pos[ $c ];
                        for my $l ( 0 .. 12 ) {
                                my $o = $l << 5; # *32
                                my $co = ( $l << 7 ) | $c;
                                $pixels[ $a + $x + $o ] = $flip[ $chars[ $co ] ];
                        }
                }
                $a += ( 32 * 13 ); # next line
        }

        my $vram = SDL::Surface->new(
                -width => 256,
                -height => 256,
                -depth => 1,    # 1 bit per pixel
                -pitch => 32,   # bytes per line
                -from => pack("C*", @pixels),
        );
        $vram->set_colors( 0, $white, $black );

        $self->render_frame( $vram );

#       $self->render_vram_text;

        printf("frame in %.2fs\n", time()-$t);
}


=head2 render_vram_text

Simple hex dumper of text buffer

=cut

my $last_dump = '';

sub render_vram_text {
        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	165	use Z80;
10			use Screen;
11	dpavlin	178	use Time::HiRes qw/time/;
12	dpavlin	130
13	dpavlin	163	use base qw(Class::Accessor VRac Z80 Screen Prefs Session);
14	dpavlin	130	__PACKAGE__->mk_accessors(qw(booted));
15
16			=head1 NAME
17
18			Galaksija - Galaksija emulator
19
20			=head1 VERSION
21
22	dpavlin	163	Version 0.01
23	dpavlin	130
24			=cut
25
26	dpavlin	163	our $VERSION = '0.01';
27	dpavlin	130
28			=head1 SUMMARY
29
30			Emulator of Galaksija 8-bit Z80 machine popular in former Yugoslavia
31
32			=cut
33
34			=head1 FUNCTIONS
35
36			=head2 run
37
38			=cut
39
40			our $emu;
41
42			sub run {
43			my $self = shift;
44	dpavlin	131
45			warn "Galaksija $Galaksija::VERSION emulation starting\n";
46
47			$self->show_mem( 1 );
48	dpavlin	137	#$self->trace( 1 );
49	dpavlin	131
50	dpavlin	130	$self->SUPER::init(
51			read => sub { $self->read( @_ ) },
52			write => sub { $self->write( @_ ) },
53			);
54
55			for my $a ( 0x1000 .. 0x2000 ) {
56			$mem[$a] = 0xff;
57			}
58
59			$self->open_screen;
60			$self->load_rom({
61			0x0000, 'rom/Galaksija/ROM1.BIN',
62	dpavlin	164	0x1000, 'rom/Galaksija/ROM2.BIN',
63	dpavlin	130	# 0xE000, 'rom/Galaksija/GAL_PLUS.BIN',
64			});
65
66			# keyboard
67			$mem[$_] = 0xff foreach ( 0x2000 .. 0x2800 );
68
69			# display
70	dpavlin	139	$mem[$_] = 0x20 foreach ( 0x2800 .. 0x2a00 );
71	dpavlin	130
72			# 6116-ice
73			$mem[$_] = 0 foreach ( 0x2a00 .. 0x4000 );
74
75			$emu = $self;
76
77			my ( $trace, $debug ) = ( $self->trace, $self->debug );
78			$self->trace( 0 );
79			$self->debug( 0 );
80
81	dpavlin	137	warn "rendering memory\n";
82			$self->render_mem( @mem );
83	dpavlin	130
84			#$self->sync;
85			$self->trace( $trace );
86			$self->debug( $debug );
87
88			warn "Galaksija boot finished",
89			$self->trace ? ' trace' : '',
90			$self->debug ? ' debug' : '',
91			"\n";
92
93			Z80::reset();
94
95	dpavlin	140	my $hor_pos = 0;
96
97	dpavlin	130	$self->loop( sub {
98	dpavlin	178	my $run_for = shift;
99			Z80::exec( $run_for );
100	dpavlin	140	if ( $hor_pos != $mem[ 0x2ba8 ] ) {
101			warn "scroll 0x2ba8", $self->hexdump( 0x2ba8 );
102			$hor_pos = $mem[ 0x2ba8 ];
103			}
104	dpavlin	137	$self->render_vram;
105	dpavlin	130	});
106
107			}
108
109
110			=head1 Memory management
111
112			=cut
113
114			=head2 read
115
116			Read from memory
117
118			$byte = read( $address );
119
120			=cut
121
122			sub read {
123			my $self = shift;
124			my ($addr) = @_;
125			my $byte = $mem[$addr];
126			confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
127			warn sprintf("# Galaksija::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
128
129	dpavlin	137	$self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
130	dpavlin	130	return $byte;
131			}
132
133			=head2 write
134
135			Write into emory
136
137			write( $address, $byte );
138
139			=cut
140
141			sub write {
142			my $self = shift;
143			my ($addr,$byte) = @_;
144			warn sprintf("# Galaksija::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
145
146	dpavlin	140	return if ( $addr > 0x4000 );
147
148	dpavlin	137	$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
149	dpavlin	130	$mem[$addr] = $byte;
150			return;
151			}
152
153	dpavlin	137	=head1 Architecture specific
154
155	dpavlin	163	=cut
156
157			my @keymap = (
158			'a' .. 'z',
159			qw/up down left right space/,
160			'0' .. '9',
161	dpavlin	168	':', '"', ',', '=', '.', '/', 'return', 'tab',
162			'left alt', 'backspace', 'scroll lock', 'left shift'
163	dpavlin	163	);
164
165			my $remap;
166			my $o = 1;
167
168			foreach my $key ( @keymap ) {
169			$remap->{$key} = $o;
170			$o++;
171			}
172
173			=head2 key_down
174
175			=cut
176
177			sub key_down {
178			my ( $self, $key ) = @_;
179	dpavlin	178	warn "registered key down: $key ", $remap->{$key};
180	dpavlin	163	$self->write( 0x2000 + $remap->{$key}, 0xfe );
181			}
182
183			=head2 key_up
184
185			=cut
186
187			sub key_up {
188			my ( $self, $key ) = @_;
189	dpavlin	178	warn "registred key up: $key ", $remap->{$key};
190	dpavlin	163	$self->write( 0x2000 + $remap->{$key}, 0xff );
191			}
192
193	dpavlin	137	=head2 render_vram
194
195	dpavlin	164	Render characters as graphic
196
197			=cut
198
199			my $char_rom = 'rom/Galaksija/CHRGEN.BIN';
200
201			my @chars = map { ord($_) } split(//, read_file( $char_rom ));
202			warn "loaded ", $#chars, " characters\n";
203
204			my @char2pos;
205
206			# maken from mess/video/galaxy.c
207			foreach my $char ( 0 .. 255 ) {
208			my $c = $char;
209			if ( ( $c > 63 && $c < 96 ) \|\| ( $c > 127 && $c < 192 ) ) {
210			$c -= 64;
211			} elsif ( $c > 191 ) {
212			$c -= 128;
213			}
214			$char2pos[ $char ] = ( $c & 0x7f );
215			}
216
217			warn dump( @char2pos );
218
219			sub render_vram {
220			my $self = shift;
221
222	dpavlin	178	my $t = time();
223
224	dpavlin	164	my $addr = 0x2800;
225
226			my @pixels = ("\x00") x ( 32 * 16 * 13 );
227			my $a = 0;
228
229			for my $y ( 0 .. 15 ) {
230			for my $x ( 0 .. 31 ) {
231			my $c = $mem[ $addr++ ];
232			$c = $char2pos[ $c ];
233			for my $l ( 0 .. 12 ) {
234			my $o = $l << 5; # *32
235			my $co = ( $l << 7 ) \| $c;
236	dpavlin	165	$pixels[ $a + $x + $o ] = $flip[ $chars[ $co ] ];
237	dpavlin	164	}
238			}
239			$a += ( 32 * 13 ); # next line
240			}
241
242			my $vram = SDL::Surface->new(
243			-width => 256,
244			-height => 256,
245			-depth => 1, # 1 bit per pixel
246			-pitch => 32, # bytes per line
247			-from => pack("C*", @pixels),
248			);
249	dpavlin	168	$vram->set_colors( 0, $white, $black );
250	dpavlin	164
251			$self->render_frame( $vram );
252
253			# $self->render_vram_text;
254	dpavlin	178
255			printf("frame in %.2fs\n", time()-$t);
256	dpavlin	164	}
257
258
259			=head2 render_vram_text
260
261	dpavlin	137	Simple hex dumper of text buffer
262
263			=cut
264
265	dpavlin	139	my $last_dump = '';
266
267	dpavlin	164	sub render_vram_text {
268	dpavlin	137	my $self = shift;
269
270			my $addr = 0x2800;
271
272	dpavlin	139	my $dump;
273
274	dpavlin	137	for my $y ( 0 .. 15 ) {
275	dpavlin	140	# $dump .= sprintf "%2d: %s\n",$y, join('', map { sprintf("%02x ",$_) } @mem[ $addr .. $addr+31 ] );
276			$dump .= sprintf "%2d: %s\n",$y, join('', map { chr( $_ ) } @mem[ $addr .. $addr+31 ] );
277	dpavlin	137	$addr += 32;
278			}
279	dpavlin	140
280			if ( $mem[ 0x2bb0 ] ) {
281			warn "scroll", $self->hexdump( 0x2bb0 );
282			}
283
284	dpavlin	139	if ( $dump ne $last_dump ) {
285			print $dump;
286			$last_dump = $dump;
287			}
288	dpavlin	137	}
289
290	dpavlin	131	=head2 cpu_PC
291
292			Helper metod to set or get PC for current architecture
293
294			=cut
295
296			sub cpu_PC {
297			my ( $self, $addr ) = @_;
298			if ( defined($addr) ) {
299			$PC = $addr;
300			warn sprintf("running from PC %04x\n", $PC);
301			};
302			return $PC;
303			}
304
305	dpavlin	137	=head1 SEE ALSO
306
307			L<VRac>, L<Screen>, L<Z80>
308
309	dpavlin	130	=head1 AUTHOR
310
311			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
312
313			=head1 BUGS
314
315	dpavlin	148	Galaksija Plus isn't emulated. I don't have additional rom, but I would
316			B<love> to have support for this machine. So if you have ROM for Galaksija
317			Plus, get in touch!
318
319	dpavlin	130	=head1 ACKNOWLEDGEMENTS
320
321	dpavlin	148	Based on Galaxy emulator L<http://emulator.galaksija.org/> for Windows which
322			is in turn based on DOS version by Miodrag Jevremoviæ
323			L<http://solair.eunet.yu/~jovkovic/galaxy/>.
324	dpavlin	130
325			=head1 COPYRIGHT & LICENSE
326
327			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
328
329			This program is free software; you can redistribute it and/or modify it
330			under the same terms as Perl itself.
331
332			=cut
333
334			1; # End of Galaksija