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

  ViewVC Help
Powered by ViewVC 1.1.26