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

  ViewVC Help
Powered by ViewVC 1.1.26