/[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 163 - (hide annotations)
Sun Aug 5 20:02:14 2007 UTC (11 years, 10 months ago) by dpavlin
File size: 4497 byte(s)
use new key_up/key_down to implement keyboard
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

  ViewVC Help
Powered by ViewVC 1.1.26