1 |
#!/usr/bin/perl |
2 |
|
3 |
use strict; |
4 |
use warnings; |
5 |
|
6 |
use Orao; |
7 |
use Carp; |
8 |
use Data::Dump qw/dump/; |
9 |
|
10 |
use SDL::App; |
11 |
use SDL::Rect; |
12 |
use SDL::Color; |
13 |
|
14 |
my $debug = shift @ARGV; |
15 |
$debug = 1; |
16 |
|
17 |
my $scale = 2; |
18 |
my $show_mem = 1; |
19 |
|
20 |
my $app = SDL::App->new( |
21 |
-width => 256 * $scale + ( $show_mem ? 256 : 0 ), |
22 |
-height => 256 * $scale, |
23 |
-depth => 16, |
24 |
); |
25 |
|
26 |
$app->grab_input( 0 ); |
27 |
|
28 |
my $white = SDL::Color->new( -r => 0xff, -g => 0xff, -b => 0xff ); |
29 |
my $black = SDL::Color->new( -r => 0x80, -g => 0x80, -b => 0x80 ); |
30 |
|
31 |
my $red = SDL::Color->new( -r => 0xff, -g => 0x00, -b => 0x00 ); |
32 |
my $green = SDL::Color->new( -r => 0x00, -g => 0xff, -b => 0x00 ); |
33 |
my $blue = SDL::Color->new( -r => 0x00, -g => 0x00, -b => 0xff ); |
34 |
|
35 |
sub p { |
36 |
my ($x,$y,$w) = (@_); |
37 |
|
38 |
my $rect = SDL::Rect->new( |
39 |
-height => $scale, |
40 |
-width => $scale, |
41 |
-x => $x, |
42 |
-y => $y, |
43 |
); |
44 |
|
45 |
$app->fill( $rect, $w ? $white : $black ); |
46 |
$app->update( $rect ); |
47 |
} |
48 |
|
49 |
my $stat; |
50 |
|
51 |
my @vram = (0) x 0x2000; |
52 |
|
53 |
my $orao = new Orao({ |
54 |
vram => sub { |
55 |
my ( $offset, $byte ) = @_; |
56 |
my $x = $offset & 0xff; |
57 |
my $y = $offset >> 8; |
58 |
my $mask = 1; |
59 |
my $changed = $vram[$offset] ^ $byte; |
60 |
|
61 |
foreach ( 0 .. 7 ) { |
62 |
next if $changed & $mask; |
63 |
p($x + $_,$y, $byte & $mask ); |
64 |
$mask = $mask << 1; |
65 |
} |
66 |
}, |
67 |
mem_acc => sub { |
68 |
my ( $offset, $what, $value ) = @_; |
69 |
my $x = $offset & 0xff; |
70 |
$x += 256 * $scale; |
71 |
my $y = $offset >> 8; |
72 |
#warn "mem_acc $offset $x $y\n"; |
73 |
|
74 |
my ( $r,$g,$b ) = ( 128,128,128 ); |
75 |
|
76 |
if ( $what eq 'write' ) { |
77 |
$r = $value; |
78 |
} elsif ( $what eq 'read' ) { |
79 |
$g = $value; |
80 |
} else { |
81 |
$b = $value; |
82 |
} |
83 |
|
84 |
my $col = SDL::Color->new( -r => $r, -g => $g, -b => $b ); |
85 |
$app->pixel( $x, $y, $col ); |
86 |
|
87 |
$stat->{$what}++; |
88 |
if ( $stat->{$what} % 10000 == 0 ) { |
89 |
warn "."; |
90 |
$app->sync; |
91 |
} |
92 |
}, |
93 |
}); |
94 |
|
95 |
my ($pc, $a, $x, $y, $s, $p) = (0) x 6; |
96 |
$orao->load_rom('rom/BAS12.ROM', 0xC000); |
97 |
$orao->load_rom('rom/CRT12.ROM', 0xE000); |
98 |
#$orao->load_rom('dump/basic.dmp', -2); |
99 |
|
100 |
$pc = 0xDD11; # BC |
101 |
#$pc = 0xC274; # MC |
102 |
|
103 |
#$orao->load_rom('makewav/SCRINV.BIN', 0x1000); |
104 |
#$pc = 0x1000; |
105 |
|
106 |
$orao->load_rom('dump/64k.bin', 0); |
107 |
#$pc = 0xe5b7; |
108 |
|
109 |
my $rect = SDL::Rect->new( |
110 |
-height => 256, |
111 |
-width => 256, |
112 |
-x => 256 * $scale, |
113 |
-y => 0, |
114 |
); |
115 |
|
116 |
$app->fill( $rect, $white ); |
117 |
$app->update( $rect ); |
118 |
|
119 |
warn "rendering memory map\n"; |
120 |
for my $a ( 0x0000 .. 0xffff ) { |
121 |
$orao->read_8( $a ); |
122 |
} |
123 |
|
124 |
$orao->set_pc( $pc ); |
125 |
$orao->set_a( $a ); |
126 |
$orao->set_x( $x ); |
127 |
$orao->set_y( $y ); |
128 |
$orao->set_s( $s ); |
129 |
$orao->set_p( $p ); |
130 |
|
131 |
printf "starting emulation -- pc: %04x a:%d x:%d y:%d s:%d p:%d\n", $pc, $a, $x, $y, $s, $p; |
132 |
|
133 |
my $c = 0; |
134 |
|
135 |
sub hexdump { |
136 |
my $a = shift; |
137 |
return sprintf "%04x: %08x %08x %08x %08x\n", $a, map { $orao->read_32( $a + $_ ) } ( 0, 4, 8, 12 ); |
138 |
} |
139 |
|
140 |
my $last; |
141 |
|
142 |
sub prompt { |
143 |
my $a = shift; |
144 |
print hexdump( $a ), |
145 |
$last ? " [$last]" : '', |
146 |
"> "; |
147 |
my $in = <STDIN>; |
148 |
chomp($in); |
149 |
$in ||= $last; |
150 |
$last = $in; |
151 |
return split(/\s+/, $in); |
152 |
} |
153 |
|
154 |
while ( 1 ) { |
155 |
$orao->run(3, sub { |
156 |
my ($pc, $inst, $a, $x, $y, $s, $p) = @_; |
157 |
printf "%04x inst: %x a:%d x:%d y:%d s:%d p:%d\n", @_ if ( $debug || $c++ % 1000 == 0 ); |
158 |
if ( $debug ) { |
159 |
my $a = $pc; |
160 |
while ( my ( $c, $v ) = prompt( $a ) ) { |
161 |
if ( $c =~ m/^[qx]/i ) { |
162 |
die; |
163 |
} elsif ( $c =~ m/^m/i ) { |
164 |
$a = hex( $v ); |
165 |
} elsif ( $c =~ m/^\+/ ) { |
166 |
$a += 16; |
167 |
} elsif ( $c =~ m/^\-/ ) { |
168 |
$a -= 16; |
169 |
} else { |
170 |
warn "# ignore $c\n"; |
171 |
last; |
172 |
} |
173 |
warn hexdump( $a ); |
174 |
} |
175 |
} |
176 |
}); |
177 |
} |