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

  ViewVC Help
Powered by ViewVC 1.1.26