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

=head1 NAME

Galaksija - Galaksija emulator

=head1 VERSION

Version 0.00

=cut

our $VERSION = '0.00';

=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

my $keyboard = {};

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

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

Based on Galaxy Win emulator L<http://emulator.galaksija.org/>

=head1 BUGS

=head1 ACKNOWLEDGEMENTS

See also L<> 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 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			use base qw(Class::Accessor VRac Z80 Screen Prefs);
12			__PACKAGE__->mk_accessors(qw(booted));
13
14			=head1 NAME
15
16			Galaksija - Galaksija emulator
17
18			=head1 VERSION
19
20			Version 0.00
21
22			=cut
23
24			our $VERSION = '0.00';
25
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			my $keyboard = {};
120
121			sub read {
122			my $self = shift;
123			my ($addr) = @_;
124			my $byte = $mem[$addr];
125			confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
126			warn sprintf("# Galaksija::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
127
128	dpavlin	137	$self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
129	dpavlin	130	return $byte;
130			}
131
132			=head2 write
133
134			Write into emory
135
136			write( $address, $byte );
137
138			=cut
139
140			sub write {
141			my $self = shift;
142			my ($addr,$byte) = @_;
143			warn sprintf("# Galaksija::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
144
145	dpavlin	140	return if ( $addr > 0x4000 );
146
147	dpavlin	137	$self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
148	dpavlin	130	$mem[$addr] = $byte;
149			return;
150			}
151
152	dpavlin	137	=head1 Architecture specific
153
154			=head2 render_vram
155
156			Simple hex dumper of text buffer
157
158			=cut
159
160	dpavlin	139	my $last_dump = '';
161
162	dpavlin	137	sub render_vram {
163			my $self = shift;
164
165			my $addr = 0x2800;
166
167	dpavlin	139	my $dump;
168
169	dpavlin	137	for my $y ( 0 .. 15 ) {
170	dpavlin	140	# $dump .= sprintf "%2d: %s\n",$y, join('', map { sprintf("%02x ",$_) } @mem[ $addr .. $addr+31 ] );
171			$dump .= sprintf "%2d: %s\n",$y, join('', map { chr( $_ ) } @mem[ $addr .. $addr+31 ] );
172	dpavlin	137	$addr += 32;
173			}
174	dpavlin	140
175			if ( $mem[ 0x2bb0 ] ) {
176			warn "scroll", $self->hexdump( 0x2bb0 );
177			}
178
179	dpavlin	139	if ( $dump ne $last_dump ) {
180			print $dump;
181			$last_dump = $dump;
182			}
183	dpavlin	137	}
184
185	dpavlin	131	=head2 cpu_PC
186
187			Helper metod to set or get PC for current architecture
188
189			=cut
190
191			sub cpu_PC {
192			my ( $self, $addr ) = @_;
193			if ( defined($addr) ) {
194			$PC = $addr;
195			warn sprintf("running from PC %04x\n", $PC);
196			};
197			return $PC;
198			}
199
200	dpavlin	137	=head1 SEE ALSO
201
202			L<VRac>, L<Screen>, L<Z80>
203
204	dpavlin	130	=head1 AUTHOR
205
206			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
207
208	dpavlin	137	Based on Galaxy Win emulator L<http://emulator.galaksija.org/>
209
210	dpavlin	130	=head1 BUGS
211
212			=head1 ACKNOWLEDGEMENTS
213
214			See also L<> which is source of all
215			info about this machine (and even hardware implementation from 2007).
216
217			=head1 COPYRIGHT & LICENSE
218
219			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
220
221			This program is free software; you can redistribute it and/or modify it
222			under the same terms as Perl itself.
223
224			=cut
225
226			1; # End of Galaksija