/[VRac]/Galaksija.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /Galaksija.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.26