8 |
#use Time::HiRes qw(time); |
#use Time::HiRes qw(time); |
9 |
use File::Slurp; |
use File::Slurp; |
10 |
use Data::Dump qw/dump/; |
use Data::Dump qw/dump/; |
|
use List::Util qw/first/; |
|
11 |
use M6502; |
use M6502; |
12 |
|
|
13 |
use base qw(Class::Accessor M6502 Screen Prefs); |
use base qw(Class::Accessor M6502 Screen Prefs); |
31 |
|
|
32 |
=cut |
=cut |
33 |
|
|
|
my @kbd_ports = ( |
|
|
0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7, |
|
|
0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF, |
|
|
0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF, |
|
|
0x83FE,0x83FF, |
|
|
); |
|
|
|
|
34 |
=head1 FUNCTIONS |
=head1 FUNCTIONS |
35 |
|
|
36 |
=head2 boot |
=head2 boot |
299 |
|
|
300 |
=cut |
=cut |
301 |
|
|
302 |
|
my $keyboard_none = 255; |
303 |
|
|
304 |
my $keyboard = { |
my $keyboard = { |
305 |
0x87FC => { |
0x87FC => { |
306 |
'right' => 16, |
'right' => 16, |
313 |
my ( $self, $key ) = @_; |
my ( $self, $key ) = @_; |
314 |
if ( $key eq 'return' ) { |
if ( $key eq 'return' ) { |
315 |
M6502::_write( 0xfc, 13 ); |
M6502::_write( 0xfc, 13 ); |
316 |
|
warn "return\n"; |
317 |
return 0; |
return 0; |
318 |
} elsif ( $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) { |
} elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) { |
319 |
|
warn "ctrl\n"; |
320 |
return 16; |
return 16; |
321 |
} |
} |
322 |
|
return $keyboard_none; |
323 |
}, |
}, |
324 |
0x87FA => { |
0x87FA => { |
325 |
'f4' => 16, |
'f4' => 16, |
332 |
if ( $key eq 'space' ) { |
if ( $key eq 'space' ) { |
333 |
return 32; |
return 32; |
334 |
} elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) { |
} elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) { |
335 |
|
warn "shift\n"; |
336 |
return 16; |
return 16; |
337 |
} |
} |
338 |
|
return $keyboard_none; |
339 |
}, |
}, |
340 |
0x87F6 => { |
0x87F6 => { |
341 |
'6' => 16, |
'6' => 16, |
342 |
't' => 128, |
't' => 128, |
343 |
'z' => 192, |
'y' => 192, # hr: z |
344 |
'r' => 224, |
'r' => 224, |
345 |
}, |
}, |
346 |
0x87F7 => { |
0x87F7 => { |
374 |
'l' => 224, |
'l' => 224, |
375 |
}, |
}, |
376 |
0x87BF => { |
0x87BF => { |
377 |
',' => 32, |
',' => 32, # < |
378 |
'.' => 16, |
'.' => 16, # > |
379 |
}, |
}, |
380 |
0x877E => { |
0x877E => { |
381 |
'y' => 16, |
'z' => 16, # hr:y |
382 |
's' => 128, |
's' => 128, |
383 |
'a' => 192, |
'a' => 192, |
384 |
'd' => 224, |
'd' => 224, |
398 |
'v' => 16, |
'v' => 16, |
399 |
}, |
}, |
400 |
0x85FE => { |
0x85FE => { |
401 |
';' => sub { $_[0]->key_down('left shift') ? 16 : 224 }, |
'<' => 16, # : |
402 |
'\\' => 128, |
'\\' => 128, # ¾ |
403 |
'\'' => 192, |
'\'' => 192, # æ |
404 |
# ';' => 224, |
';' => 224, # è |
|
'8' => 16, # FIXME? |
|
405 |
}, |
}, |
406 |
0x85FF => { |
0x85FF => { |
407 |
'/' => 32, |
'/' => 32, |
408 |
'6' => 16, # FIXME? |
'f11' => 16, # ^ |
409 |
}, |
}, |
410 |
0x83FE => { |
0x83FE => { |
411 |
';' => 16, |
'f12' => 16, # ; |
412 |
'[' => 128, |
'[' => 128, # ¹ |
413 |
']' => 192, |
']' => 192, # ð |
414 |
'p' => 224, |
'p' => 224, |
|
'=' => 16, # FIXME? |
|
415 |
}, |
}, |
416 |
0x83FF => { |
0x83FF => { |
417 |
'-' => 32, |
'-' => 32, |
419 |
}, |
}, |
420 |
}; |
}; |
421 |
|
|
|
my $keyboard_none = 255; |
|
|
|
|
422 |
sub read { |
sub read { |
423 |
my $self = shift; |
my $self = shift; |
424 |
my ($addr) = @_; |
my ($addr) = @_; |
428 |
|
|
429 |
# keyboard |
# keyboard |
430 |
|
|
431 |
if ( first { $addr == $_ } @kbd_ports ) { |
if ( defined( $keyboard->{$addr} ) ) { |
432 |
warn sprintf("keyboard port: %04x\n",$addr) if $self->trace; |
warn sprintf("keyboard port: %04x\n",$addr) if $self->trace; |
433 |
my $key = $self->key_pressed; |
my $key = $self->key_pressed; |
434 |
if ( defined($key) ) { |
if ( defined($key) ) { |
436 |
my $r = $keyboard->{$addr} || confess "no definition for keyboard port found"; |
my $r = $keyboard->{$addr} || confess "no definition for keyboard port found"; |
437 |
if ( ref($r) eq 'CODE' ) { |
if ( ref($r) eq 'CODE' ) { |
438 |
$ret = $r->($self, $key); |
$ret = $r->($self, $key); |
439 |
} elsif ( $ret = $r->{$key} ) { |
} elsif ( defined($r->{$key}) ) { |
440 |
|
$ret = $r->{$key}; |
441 |
if ( ref($ret) eq 'CODE' ) { |
if ( ref($ret) eq 'CODE' ) { |
442 |
$ret = $ret->($self); |
$ret = $ret->($self); |
|
warn "executed $key and got: $ret\n"; |
|
|
} else { |
|
|
warn sprintf("keyboard port: %04x key: '%s' code: %02x\n", $addr, $key, $ret); |
|
443 |
} |
} |
|
$mem[$addr] = $ret; |
|
|
warn "keypress: $key = $ret\n"; |
|
|
return $ret; |
|
444 |
} else { |
} else { |
445 |
warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug; |
warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug; |
446 |
} |
} |
447 |
warn sprintf("keyboard port: %04x %s\n",$addr,dump( $r )) if $self->trace; |
warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none ); |
448 |
|
return $ret; |
449 |
} |
} |
450 |
return $keyboard_none; |
return $keyboard_none; |
451 |
} |
} |