/[VRac]/Orao.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 /Orao.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 124 - (hide annotations)
Sat Aug 4 14:13:28 2007 UTC (16 years, 7 months ago) by dpavlin
File size: 8124 byte(s)
re-organize file patch to new VRac layout to ease re-use of code
1 dpavlin 29 package Orao;
2    
3     use warnings;
4     use strict;
5    
6 dpavlin 56 use Carp qw/confess/;
7 dpavlin 29 use lib './lib';
8     #use Time::HiRes qw(time);
9     use File::Slurp;
10 dpavlin 32 use Data::Dump qw/dump/;
11 dpavlin 34 use M6502;
12 dpavlin 29
13 dpavlin 124 use base qw(Class::Accessor VRac M6502 Screen Prefs Tape);
14     #__PACKAGE__->mk_accessors(qw());
15 dpavlin 29
16     =head1 NAME
17    
18     Orao - Orao emulator
19    
20     =head1 VERSION
21    
22 dpavlin 95 Version 0.04
23 dpavlin 29
24     =cut
25    
26 dpavlin 95 our $VERSION = '0.04';
27 dpavlin 29
28     =head1 SUMMARY
29    
30     Emulator or Orao 8-bit 6502 machine popular in Croatia
31    
32     =cut
33    
34 dpavlin 95 =head1 FUNCTIONS
35    
36 dpavlin 82 =head2 boot
37 dpavlin 30
38 dpavlin 56 Start emulator, open L<Screen>, load initial ROM images, and render memory
39 dpavlin 30
40 dpavlin 115 my $emu = Orao->new({});
41     $emu->boot;
42 dpavlin 82
43 dpavlin 30 =cut
44    
45 dpavlin 115 our $emu;
46 dpavlin 32
47 dpavlin 42 select(STDERR); $| = 1;
48    
49 dpavlin 82 sub boot {
50 dpavlin 30 my $self = shift;
51 dpavlin 34 warn "Orao calling upstream init\n";
52 dpavlin 90 $self->SUPER::init(
53     read => sub { $self->read( @_ ) },
54     write => sub { $self->write( @_ ) },
55     );
56 dpavlin 30
57 dpavlin 56 warn "Orao $Orao::VERSION emulation starting\n";
58 dpavlin 30
59 dpavlin 90 warn "emulating ", $#mem, " bytes of memory\n";
60    
61 dpavlin 30 $self->open_screen;
62 dpavlin 33 $self->load_rom({
63 dpavlin 124 # 0x1000 => 'dump/SCRINV.BIN',
64 dpavlin 76 # should be 0x6000, but oraoemu has 2 byte prefix
65 dpavlin 124 # 0x5FFE => 'dump/screen.dmp',
66     # 0xC000 => 'rom/Orao/BAS12.ROM',
67     # 0xE000 => 'rom/Orao/CRT12.ROM',
68     0xC000 => 'rom/Orao/BAS13.ROM',
69     0xE000 => 'rom/Orao/CRT13.ROM',
70 dpavlin 33 });
71 dpavlin 32
72 dpavlin 73 # $PC = 0xDD11; # BC
73 dpavlin 46 # $PC = 0xC274; # MC
74 dpavlin 35
75 dpavlin 78 $PC = 0xff89;
76    
77 dpavlin 115 $emu = $self;
78 dpavlin 32
79 dpavlin 33 # $self->prompt( 0x1000 );
80    
81 dpavlin 49 my ( $trace, $debug ) = ( $self->trace, $self->debug );
82 dpavlin 38 $self->trace( 0 );
83 dpavlin 49 $self->debug( 0 );
84 dpavlin 33
85 dpavlin 107 warn "rendering video memory\n";
86     $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
87 dpavlin 73
88 dpavlin 38 if ( $self->show_mem ) {
89 dpavlin 33
90 dpavlin 38 warn "rendering memory map\n";
91    
92 dpavlin 76 $self->render_mem( @mem );
93    
94 dpavlin 38 my @mmap = (
95     0x0000, 0x03FF, 'nulti blok',
96     0x0400, 0x5FFF, 'korisnièki RAM (23K)',
97     0x6000, 0x7FFF, 'video RAM',
98     0x8000, 0x9FFF, 'sistemske lokacije',
99     0xA000, 0xAFFF, 'ekstenzija',
100     0xB000, 0xBFFF, 'DOS',
101     0xC000, 0xDFFF, 'BASIC ROM',
102     0xE000, 0xFFFF, 'sistemski ROM',
103     );
104    
105 dpavlin 33 }
106 dpavlin 38 $self->sync;
107     $self->trace( $trace );
108 dpavlin 49 $self->debug( $debug );
109 dpavlin 33
110 dpavlin 39 #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
111 dpavlin 34
112 dpavlin 82 warn "Orao boot finished",
113 dpavlin 49 $self->trace ? ' trace' : '',
114     $self->debug ? ' debug' : '',
115     "\n";
116 dpavlin 38
117 dpavlin 82 M6502::reset();
118    
119 dpavlin 95 $self->booted( 1 );
120 dpavlin 30 }
121    
122 dpavlin 95 =head2 run
123    
124     Run interactive emulation loop
125    
126 dpavlin 115 $emu->run;
127 dpavlin 95
128     =cut
129    
130     sub run {
131     my $self = shift;
132    
133     $self->boot if ( ! $self->booted );
134 dpavlin 110
135 dpavlin 117 # $self->load_tape( '../oraoigre/bdash.tap' );
136 dpavlin 110
137 dpavlin 96 $self->loop;
138 dpavlin 95 };
139    
140     =head1 Helper functions
141    
142 dpavlin 29 =cut
143    
144 dpavlin 61 # write chunk directly into memory, updateing vram if needed
145 dpavlin 46 sub _write_chunk {
146     my $self = shift;
147     my ( $addr, $chunk ) = @_;
148     $self->write_chunk( $addr, $chunk );
149     my $end = $addr + length($chunk);
150     my ( $f, $t ) = ( 0x6000, 0x7fff );
151    
152     if ( $end < $f || $addr >= $t ) {
153     warn "skip vram update\n";
154     return;
155     };
156    
157     $f = $addr if ( $addr > $f );
158     $t = $end if ( $end < $t );
159    
160     warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
161 dpavlin 107 $self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
162 dpavlin 77 $self->render_mem( @mem ) if $self->show_mem;
163 dpavlin 46 }
164    
165 dpavlin 94 =head2 load_image
166 dpavlin 61
167     Load binary files, ROM images and Orao Emulator files
168    
169 dpavlin 115 $emu->load_image( '/path/to/file', 0x1000 );
170 dpavlin 61
171     Returns true on success.
172    
173     =cut
174    
175 dpavlin 94 sub load_image {
176 dpavlin 29 my $self = shift;
177     my ( $path, $addr ) = @_;
178    
179 dpavlin 61 if ( ! -e $path ) {
180     warn "ERROR: file $path doesn't exist\n";
181     return;
182     }
183    
184 dpavlin 31 my $size = -s $path || confess "no size for $path: $!";
185 dpavlin 29
186     my $buff = read_file( $path );
187    
188     if ( $size == 65538 ) {
189     $addr = 0;
190 dpavlin 33 warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
191 dpavlin 46 $self->_write_chunk( $addr, substr($buff,2) );
192 dpavlin 61 return 1;
193 dpavlin 29 } elsif ( $size == 32800 ) {
194     $addr = 0;
195 dpavlin 33 warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
196 dpavlin 46 $self->_write_chunk( $addr, substr($buff,0x20) );
197 dpavlin 61 return 1;
198 dpavlin 29 }
199 dpavlin 33 printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
200 dpavlin 61 $self->_write_chunk( $addr, $buff );
201     return 1;
202 dpavlin 29
203     my $chunk;
204    
205     my $pos = 0;
206    
207     while ( my $long = substr($buff,$pos,4) ) {
208     my @b = split(//, $long, 4);
209     $chunk .=
210     ( $b[3] || '' ) .
211     ( $b[2] || '' ) .
212     ( $b[1] || '' ) .
213     ( $b[0] || '' );
214     $pos += 4;
215     }
216    
217 dpavlin 46 $self->_write_chunk( $addr, $chunk );
218 dpavlin 29
219 dpavlin 61 return 1;
220 dpavlin 29 };
221    
222    
223 dpavlin 32 =head1 Memory management
224 dpavlin 30
225 dpavlin 32 Orao implements all I/O using mmap addresses. This was main reason why
226     L<Acme::6502> was just too slow to handle it.
227    
228     =cut
229    
230     =head2 read
231    
232     Read from memory
233    
234     $byte = read( $address );
235    
236     =cut
237    
238 dpavlin 105 my $keyboard_none = 255;
239    
240 dpavlin 98 my $keyboard = {
241     0x87FC => {
242     'right' => 16,
243     'down' => 128,
244     'up' => 192,
245     'left' => 224,
246     'backspace' => 224,
247     },
248 dpavlin 103 0x87FD => sub {
249     my ( $self, $key ) = @_;
250     if ( $key eq 'return' ) {
251 dpavlin 101 M6502::_write( 0xfc, 13 );
252 dpavlin 105 warn "return\n";
253 dpavlin 98 return 0;
254 dpavlin 105 } elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
255     warn "ctrl\n";
256 dpavlin 103 return 16;
257     }
258 dpavlin 105 return $keyboard_none;
259 dpavlin 98 },
260     0x87FA => {
261     'f4' => 16,
262     'f3' => 128,
263     'f2' => 192,
264     'f1' => 224,
265     },
266 dpavlin 103 0x87FB => sub {
267     my ( $self, $key ) = @_;
268     if ( $key eq 'space' ) {
269     return 32;
270     } elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
271 dpavlin 105 warn "shift\n";
272 dpavlin 103 return 16;
273 dpavlin 110 # } elsif ( $self->tape ) {
274     # warn "has tape!";
275     # return 0;
276 dpavlin 103 }
277 dpavlin 105 return $keyboard_none;
278 dpavlin 98 },
279     0x87F6 => {
280     '6' => 16,
281     't' => 128,
282 dpavlin 105 'y' => 192, # hr: z
283 dpavlin 98 'r' => 224,
284     },
285     0x87F7 => {
286     '5' => 32,
287     '4' => 16,
288     },
289     0x87EE => {
290     '7' => 16,
291     'u' => 128,
292     'i' => 192,
293     'o' => 224,
294     },
295     0x87EF => {
296     '8' => 32,
297     '9' => 16,
298     },
299     0x87DE => {
300     '1' => 16,
301     'w' => 128,
302     'q' => 192,
303     'e' => 224,
304     },
305     0x87DF => {
306     '2' => 32,
307     '3' => 16,
308     },
309     0x87BE => {
310     'm' => 16,
311     'k' => 128,
312     'j' => 192,
313     'l' => 224,
314     },
315     0x87BF => {
316 dpavlin 105 ',' => 32, # <
317     '.' => 16, # >
318 dpavlin 98 },
319     0x877E => {
320 dpavlin 105 'z' => 16, # hr:y
321 dpavlin 98 's' => 128,
322     'a' => 192,
323     'd' => 224,
324     },
325     0x877F => {
326     'x' => 32,
327     'c' => 16,
328     },
329     0x86FE => {
330     'n' => 16,
331     'g' => 128,
332     'h' => 192,
333     'f' => 224,
334     },
335     0x86FF => {
336     'b' => 32,
337 dpavlin 102 'v' => 16,
338 dpavlin 98 },
339     0x85FE => {
340 dpavlin 105 '<' => 16, # :
341     '\\' => 128, # ¾
342     '\'' => 192, # æ
343     ';' => 224, # è
344 dpavlin 98 },
345     0x85FF => {
346     '/' => 32,
347 dpavlin 105 'f11' => 16, # ^
348 dpavlin 98 },
349     0x83FE => {
350 dpavlin 105 'f12' => 16, # ;
351     '[' => 128, # ¹
352     ']' => 192, # ð
353 dpavlin 98 'p' => 224,
354     },
355     0x83FF => {
356     '-' => 32,
357     '0' => 16,
358     },
359     };
360    
361 dpavlin 32 sub read {
362 dpavlin 33 my $self = shift;
363 dpavlin 32 my ($addr) = @_;
364     my $byte = $mem[$addr];
365 dpavlin 90 confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
366 dpavlin 41 warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
367 dpavlin 78
368     # keyboard
369    
370 dpavlin 105 if ( defined( $keyboard->{$addr} ) ) {
371 dpavlin 97 warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
372 dpavlin 99 my $key = $self->key_pressed;
373     if ( defined($key) ) {
374 dpavlin 103 my $ret = $keyboard_none;
375 dpavlin 98 my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
376 dpavlin 103 if ( ref($r) eq 'CODE' ) {
377     $ret = $r->($self, $key);
378 dpavlin 105 } elsif ( defined($r->{$key}) ) {
379     $ret = $r->{$key};
380 dpavlin 98 if ( ref($ret) eq 'CODE' ) {
381 dpavlin 103 $ret = $ret->($self);
382 dpavlin 98 }
383     } else {
384 dpavlin 99 warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
385 dpavlin 98 }
386 dpavlin 105 warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
387     return $ret;
388 dpavlin 98 }
389 dpavlin 101 return $keyboard_none;
390 dpavlin 78 }
391    
392 dpavlin 109 if ( $addr == 0x87ff ) {
393     return $self->read_tape;
394     }
395    
396 dpavlin 33 $self->mmap_pixel( $addr, 0, $byte, 0 );
397 dpavlin 32 return $byte;
398     }
399    
400     =head2 write
401    
402     Write into emory
403    
404     write( $address, $byte );
405    
406     =cut
407    
408     sub write {
409 dpavlin 33 my $self = shift;
410 dpavlin 32 my ($addr,$byte) = @_;
411 dpavlin 41 warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
412 dpavlin 32
413     if ( $addr == 0x8800 ) {
414     warn sprintf "sound ignored: %x\n", $byte;
415     }
416    
417 dpavlin 52 if ( $addr > 0xafff ) {
418 dpavlin 90 confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
419 dpavlin 52 }
420    
421 dpavlin 33 $self->mmap_pixel( $addr, $byte, 0, 0 );
422 dpavlin 32
423     $mem[$addr] = $byte;
424 dpavlin 36 return;
425 dpavlin 32 }
426    
427 dpavlin 29 =head1 AUTHOR
428    
429     Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
430    
431     =head1 BUGS
432    
433     =head1 ACKNOWLEDGEMENTS
434    
435     See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
436     info about this machine (and even hardware implementation from 2007).
437    
438     =head1 COPYRIGHT & LICENSE
439    
440     Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
441    
442     This program is free software; you can redistribute it and/or modify it
443     under the same terms as Perl itself.
444    
445     =cut
446    
447     1; # End of Orao

  ViewVC Help
Powered by ViewVC 1.1.26