/[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 185 - (hide annotations)
Sun Sep 30 19:47:32 2007 UTC (12 years ago) by dpavlin
File size: 6436 byte(s)
report correct screen_width and screen_height 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 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 181 if ( $addr >= 0x2000 && $addr <= 0x2036 ) {
130     # printf("## keyread 0x%04x = %02x\n", $addr, $byte);
131     $self->key_pressed( 1 ); # force process of events
132     }
133    
134 dpavlin 137 $self->mmap_pixel( $addr, 0, $byte, 0 ) if $self->show_mem;
135 dpavlin 130 return $byte;
136     }
137    
138     =head2 write
139    
140     Write into emory
141    
142     write( $address, $byte );
143    
144     =cut
145    
146     sub write {
147     my $self = shift;
148     my ($addr,$byte) = @_;
149     warn sprintf("# Galaksija::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
150    
151 dpavlin 140 return if ( $addr > 0x4000 );
152    
153 dpavlin 137 $self->mmap_pixel( $addr, $byte, 0, 0 ) if $self->show_mem;
154 dpavlin 130 $mem[$addr] = $byte;
155     return;
156     }
157    
158 dpavlin 137 =head1 Architecture specific
159    
160 dpavlin 163 =cut
161    
162     my @keymap = (
163     'a' .. 'z',
164     qw/up down left right space/,
165     '0' .. '9',
166 dpavlin 168 ':', '"', ',', '=', '.', '/', 'return', 'tab',
167     'left alt', 'backspace', 'scroll lock', 'left shift'
168 dpavlin 163 );
169    
170 dpavlin 181 my $remap_key2addr;
171 dpavlin 163 my $o = 1;
172    
173     foreach my $key ( @keymap ) {
174 dpavlin 181 $remap_key2addr->{$key} = 0x2000 + $o;
175 dpavlin 163 $o++;
176     }
177    
178 dpavlin 181 printf("keymap is mmaped 0x%04x - 0x%04x\n", 0x2000, $o);
179    
180 dpavlin 163 =head2 key_down
181    
182     =cut
183    
184     sub key_down {
185     my ( $self, $key ) = @_;
186 dpavlin 181 if ( ! defined( $remap_key2addr->{$key} ) ) {
187     warn "unknown key pressed: $key [ignoring]\n";
188     return;
189     }
190     printf("registered key down: $key address: %04x\n", $remap_key2addr->{$key} );
191     $self->write( $remap_key2addr->{$key}, 0xfe );
192 dpavlin 163 }
193    
194     =head2 key_up
195    
196     =cut
197    
198     sub key_up {
199     my ( $self, $key ) = @_;
200 dpavlin 181 if ( ! defined( $remap_key2addr->{$key} ) ) {
201     warn "unknown key released: $key [ignoring]\n";
202     return;
203     }
204     warn "registred key up: $key ", $remap_key2addr->{$key};
205     $self->write( $remap_key2addr->{$key}, 0xff );
206 dpavlin 163 }
207    
208 dpavlin 137 =head2 render_vram
209    
210 dpavlin 164 Render characters as graphic
211    
212     =cut
213    
214     my $char_rom = 'rom/Galaksija/CHRGEN.BIN';
215    
216     my @chars = map { ord($_) } split(//, read_file( $char_rom ));
217 dpavlin 185 warn "loaded ", $#chars, " bytes from $char_rom\n";
218 dpavlin 164
219     my @char2pos;
220    
221     # maken from mess/video/galaxy.c
222     foreach my $char ( 0 .. 255 ) {
223     my $c = $char;
224     if ( ( $c > 63 && $c < 96 ) || ( $c > 127 && $c < 192 ) ) {
225     $c -= 64;
226     } elsif ( $c > 191 ) {
227     $c -= 128;
228     }
229     $char2pos[ $char ] = ( $c & 0x7f );
230     }
231    
232 dpavlin 181 #warn "## chars2pos = ",dump( @char2pos );
233 dpavlin 164
234 dpavlin 185 sub screen_width { 256 }
235     sub screen_height { 16 * 13 }
236    
237 dpavlin 164 sub render_vram {
238     my $self = shift;
239    
240 dpavlin 178 my $t = time();
241    
242 dpavlin 164 my $addr = 0x2800;
243    
244     my @pixels = ("\x00") x ( 32 * 16 * 13 );
245     my $a = 0;
246    
247     for my $y ( 0 .. 15 ) {
248     for my $x ( 0 .. 31 ) {
249     my $c = $mem[ $addr++ ];
250     $c = $char2pos[ $c ];
251     for my $l ( 0 .. 12 ) {
252     my $o = $l << 5; # *32
253     my $co = ( $l << 7 ) | $c;
254 dpavlin 165 $pixels[ $a + $x + $o ] = $flip[ $chars[ $co ] ];
255 dpavlin 164 }
256     }
257     $a += ( 32 * 13 ); # next line
258     }
259    
260     my $vram = SDL::Surface->new(
261 dpavlin 185 -width => $self->screen_width,
262     -height => $self->screen_height,
263 dpavlin 164 -depth => 1, # 1 bit per pixel
264     -pitch => 32, # bytes per line
265     -from => pack("C*", @pixels),
266     );
267 dpavlin 168 $vram->set_colors( 0, $white, $black );
268 dpavlin 164
269     $self->render_frame( $vram );
270    
271     # $self->render_vram_text;
272 dpavlin 178
273 dpavlin 181 printf("frame in %.2fs\n", time()-$t) if $self->debug;
274 dpavlin 164 }
275    
276    
277     =head2 render_vram_text
278    
279 dpavlin 137 Simple hex dumper of text buffer
280    
281     =cut
282    
283 dpavlin 139 my $last_dump = '';
284    
285 dpavlin 164 sub render_vram_text {
286 dpavlin 137 my $self = shift;
287    
288     my $addr = 0x2800;
289    
290 dpavlin 139 my $dump;
291    
292 dpavlin 137 for my $y ( 0 .. 15 ) {
293 dpavlin 140 # $dump .= sprintf "%2d: %s\n",$y, join('', map { sprintf("%02x ",$_) } @mem[ $addr .. $addr+31 ] );
294     $dump .= sprintf "%2d: %s\n",$y, join('', map { chr( $_ ) } @mem[ $addr .. $addr+31 ] );
295 dpavlin 137 $addr += 32;
296     }
297 dpavlin 140
298     if ( $mem[ 0x2bb0 ] ) {
299     warn "scroll", $self->hexdump( 0x2bb0 );
300     }
301    
302 dpavlin 139 if ( $dump ne $last_dump ) {
303     print $dump;
304     $last_dump = $dump;
305     }
306 dpavlin 137 }
307    
308 dpavlin 131 =head2 cpu_PC
309    
310     Helper metod to set or get PC for current architecture
311    
312     =cut
313    
314     sub cpu_PC {
315     my ( $self, $addr ) = @_;
316     if ( defined($addr) ) {
317     $PC = $addr;
318     warn sprintf("running from PC %04x\n", $PC);
319     };
320     return $PC;
321     }
322    
323 dpavlin 137 =head1 SEE ALSO
324    
325     L<VRac>, L<Screen>, L<Z80>
326    
327 dpavlin 130 =head1 AUTHOR
328    
329     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
330    
331     =head1 BUGS
332    
333 dpavlin 148 Galaksija Plus isn't emulated. I don't have additional rom, but I would
334     B<love> to have support for this machine. So if you have ROM for Galaksija
335     Plus, get in touch!
336    
337 dpavlin 130 =head1 ACKNOWLEDGEMENTS
338    
339 dpavlin 148 Based on Galaxy emulator L<http://emulator.galaksija.org/> for Windows which
340     is in turn based on DOS version by Miodrag Jevremovi√¶
341     L<http://solair.eunet.yu/~jovkovic/galaxy/>.
342 dpavlin 130
343     =head1 COPYRIGHT & LICENSE
344    
345     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
346    
347     This program is free software; you can redistribute it and/or modify it
348     under the same terms as Perl itself.
349    
350     =cut
351    
352     1; # End of Galaksija

  ViewVC Help
Powered by ViewVC 1.1.26