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

  ViewVC Help
Powered by ViewVC 1.1.26