package Orao;

use warnings;
use strict;

use Carp qw/confess/;
use lib './lib';
#use Time::HiRes qw(time);
use File::Slurp;
use Data::Dump qw/dump/;
use M6502;

use base qw(Class::Accessor M6502 Screen Prefs Tape);
__PACKAGE__->mk_accessors(qw(booted));

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

=head1 SUMMARY

Emulator or Orao 8-bit 6502 machine popular in Croatia

=cut

=head1 FUNCTIONS

=head2 boot

Start emulator, open L<Screen>, load initial ROM images, and render memory

  my $emu = Orao->new({});
  $emu->boot;

=cut

our $emu;

select(STDERR); $| = 1;

sub boot {
	my $self = shift;
	warn "Orao calling upstream init\n";
	$self->SUPER::init(
		read => sub { $self->read( @_ ) },
		write => sub { $self->write( @_ ) },
	);

	warn "Orao $Orao::VERSION emulation starting\n";

	warn "emulating ", $#mem, " bytes of memory\n";

	$self->open_screen;
	$self->load_rom({
		0x1000 => 'dump/SCRINV.BIN',
		# should be 0x6000, but oraoemu has 2 byte prefix
		0x5FFE => 'dump/screen.dmp',
#		0xC000 => 'rom/BAS12.ROM',
#		0xE000 => 'rom/CRT12.ROM',
		0xC000 => 'rom/BAS13.ROM',
		0xE000 => 'rom/CRT13.ROM',
	});

#	$PC = 0xDD11;	# BC
#	$PC = 0xC274;	# MC

	$PC = 0xff89;

	$emu = $self;

#	$self->prompt( 0x1000 );

	my ( $trace, $debug ) = ( $self->trace, $self->debug );
	$self->trace( 0 );
	$self->debug( 0 );

	warn "rendering video memory\n";
	$self->render_vram( @mem[ 0x6000 .. 0x7fff ] );

	if ( $self->show_mem ) {

		warn "rendering memory map\n";

		$self->render_mem( @mem );

		my @mmap = (
			0x0000, 0x03FF, 'nulti blok',
			0x0400, 0x5FFF, 'korisnički RAM (23K)',
			0x6000, 0x7FFF, 'video RAM',
			0x8000, 0x9FFF, 'sistemske lokacije',
			0xA000, 0xAFFF, 'ekstenzija',
			0xB000, 0xBFFF, 'DOS',
			0xC000, 0xDFFF, 'BASIC ROM',
			0xE000, 0xFFFF, 'sistemski ROM',
		);

	}
	$self->sync;
	$self->trace( $trace );
	$self->debug( $debug );

	#( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );

	warn "Orao boot finished",
		$self->trace ? ' trace' : '',
		$self->debug ? ' debug' : '',
		"\n";

	M6502::reset();

	$self->booted( 1 );
}

=head2 run

Run interactive emulation loop

  $emu->run;

=cut

sub run {
	my $self = shift;

	$self->boot if ( ! $self->booted );

	$self->load_tape( '../oraoigre/bdash.tap' );

	$self->loop;
};

=head1 Helper functions

=head2 load_rom

called to init memory and load initial rom images

  $emu->load_rom;

=cut

sub load_rom {
    my ($self, $loaded_files) = @_;

    #my $time_base = time();

	foreach my $addr ( sort keys %$loaded_files ) {
		my $path = $loaded_files->{$addr};
		$self->load_image( $path, $addr );
	}
}

# write chunk directly into memory, updateing vram if needed
sub _write_chunk {
	my $self = shift;
	my ( $addr, $chunk ) = @_;
	$self->write_chunk( $addr, $chunk );
	my $end = $addr + length($chunk);
	my ( $f, $t ) = ( 0x6000, 0x7fff );

	if ( $end < $f || $addr >= $t ) {
		warn "skip vram update\n";
		return;
	};

	$f = $addr if ( $addr > $f );
	$t = $end if ( $end < $t );

	warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
	$self->render_vram( @mem[ 0x6000 .. 0x7fff ] );
	$self->render_mem( @mem ) if $self->show_mem;
}

=head2 load_image

Load binary files, ROM images and Orao Emulator files

  $emu->load_image( '/path/to/file', 0x1000 );

Returns true on success.

=cut

sub load_image {
	my $self = shift;
	my ( $path, $addr ) = @_;

	if ( ! -e $path ) {
		warn "ERROR: file $path doesn't exist\n";
		return;
	}

	my $size = -s $path || confess "no size for $path: $!";

	my $buff = read_file( $path );

	if ( $size == 65538 ) {
		$addr = 0;
		warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
		$self->_write_chunk( $addr, substr($buff,2) );
		return 1;
	} elsif ( $size == 32800 ) {
		$addr = 0;
		warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
		$self->_write_chunk( $addr, substr($buff,0x20) );
		return 1;
	}
	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
	$self->_write_chunk( $addr, $buff );
	return 1;

	my $chunk;

	my $pos = 0;

	while ( my $long = substr($buff,$pos,4) ) {
		my @b = split(//, $long, 4);
		$chunk .=
			( $b[3] || '' ) .
			( $b[2] || '' ) .
			( $b[1] || '' ) .
			( $b[0] || '' );
		$pos += 4;
	}

	$self->_write_chunk( $addr, $chunk );

	return 1;
};

=head2 save_dump

  $emu->save_dump( 'filename', $from, $to );

=cut

sub save_dump {
	my $self = shift;

	my ( $path, $from, $to ) = @_;

	$from ||= 0;
	$to ||= 0xffff;

	open(my $fh, '>', $path) || die "can't open $path: $!";
	print $fh $self->read_chunk( $from, $to );
	close($fh);

	my $size = -s $path;
	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
}

=head2 hexdump

  $emu->hexdump( $address );

=cut

sub hexdump {
	my $self = shift;
	my $a = shift;
	return sprintf(" %04x %s\n", $a,
		join(" ",
			map {
				if ( defined($_) ) {
					sprintf( "%02x", $_ )
				} else {
					'  '
				}
			} @mem[ $a .. $a+8 ]
		)
	);
}

=head1 Memory management

Orao implements all I/O using mmap addresses. This was main reason why
L<Acme::6502> was just too slow to handle it.

=cut

=head2 read

Read from memory

  $byte = read( $address );

=cut

my $keyboard_none = 255;

my $keyboard = {
	0x87FC => {
		'right'		=> 16,
		'down'		=> 128,
		'up'		=> 192,
		'left'		=> 224,
		'backspace' => 224,
	},
	0x87FD => sub {
		my ( $self, $key ) = @_;
		if ( $key eq 'return' ) {
			M6502::_write( 0xfc, 13 );
			warn "return\n";
			return 0;
		} elsif ( $key =~ m/ ctrl/ || $self->key_down( 'left ctrl' ) || $self->key_down( 'right ctrl' ) ) {
			warn "ctrl\n";
			return 16;
		}
		return $keyboard_none;
	},
	0x87FA => {
		'f4' => 16,
		'f3' => 128,
		'f2' => 192,
		'f1' => 224,
	},
	0x87FB => sub {
		my ( $self, $key ) = @_;
		if ( $key eq 'space' ) {
			return 32;
		} elsif ( $self->key_down( 'left shift' ) || $self->key_down( 'right shift' ) ) {
			warn "shift\n";
			return 16;
#		} elsif ( $self->tape ) {
#			warn "has tape!";
#			return 0;
		}
		return $keyboard_none;
	},
	0x87F6 => {
		'6' => 16,
		't' => 128,
		'y' => 192,	# hr: z
		'r' => 224,
	},
	0x87F7 => {
		'5' => 32,
		'4' => 16,
	},
	0x87EE => {
		'7' => 16,
		'u' => 128,
		'i' => 192,
		'o' => 224,
	},
	0x87EF => {
		'8' => 32,
		'9' => 16,
	},
	0x87DE => {
		'1' => 16,
		'w' => 128,
		'q' => 192,
		'e' => 224,
	},
	0x87DF => {
		'2' => 32,
		'3' => 16,
	},
	0x87BE => {
		'm' => 16,
		'k' => 128,
		'j' => 192,
		'l' => 224,
	},
	0x87BF => {
		',' => 32,	# <
		'.' => 16,	# >
	},
	0x877E => {
		'z' => 16,	# hr:y
		's' => 128,
		'a' => 192,
		'd' => 224,
	},
	0x877F => {
		'x' => 32,
		'c' => 16,
	},
	0x86FE => {
		'n' => 16,
		'g' => 128,
		'h' => 192,
		'f' => 224,
	},
	0x86FF => {
		'b' => 32,
		'v' => 16,
	},
	0x85FE => {
		'<' => 16,		# :
		'\\' => 128,	# ¾
		'\'' => 192,	# ę
		';' => 224,		# č
	},
	0x85FF => {
		'/' => 32,
		'f11' => 16,	# ^
	},
	0x83FE => {
		'f12' => 16,	# ;
		'[' => 128,		# ¹
		']' => 192,		# š
		'p' => 224,
	},
	0x83FF => {
		'-' => 32,
		'0' => 16,
	},
};

sub read {
	my $self = shift;
	my ($addr) = @_;
	my $byte = $mem[$addr];
	confess sprintf("can't find memory at address %04x",$addr) unless defined($byte);
	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;

	# keyboard

	if ( defined( $keyboard->{$addr} ) ) {
		warn sprintf("keyboard port: %04x\n",$addr) if $self->trace;
		my $key = $self->key_pressed;
		if ( defined($key) ) {
			my $ret = $keyboard_none;
			my $r = $keyboard->{$addr} || confess "no definition for keyboard port found";
			if ( ref($r) eq 'CODE' ) {
				$ret = $r->($self, $key);
			} elsif ( defined($r->{$key}) ) {
				$ret = $r->{$key};
				if ( ref($ret) eq 'CODE' ) {
					$ret = $ret->($self);
				}
			} else {
				warn sprintf("keyboard port: %04x unknown key: '%s'\n", $addr, $key) if $debug;
			}
			warn sprintf("keyboard port: %04x key:%s code:%d\n",$addr,$key,$ret) if ( $ret != $keyboard_none );
			return $ret;
		}
		return $keyboard_none;
	}

	if ( $addr == 0x87ff ) {
		return $self->read_tape;
	}

	$self->mmap_pixel( $addr, 0, $byte, 0 );
	return $byte;
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
	my $self = shift;
	my ($addr,$byte) = @_;
	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;

	if ( $addr == 0x8800 ) {
		warn sprintf "sound ignored: %x\n", $byte;
	}

	if ( $addr > 0xafff ) {
		confess sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
	}

	$self->mmap_pixel( $addr, $byte, 0, 0 );

	$mem[$addr] = $byte;
	return;
}

=head1 Command Line

Command-line debugging intrerface is implemented for communication with
emulated device

=head2 prompt

  my ( $entered_line, @p ) = $emu->prompt( $address, $last_command );

=cut

my $last = 'r 1';

sub prompt {
	my $self = shift;
	$self->app->sync;
	my $a = shift;
	print $self->hexdump( $a ),
		$last ? "[$last] " : '',
		"> ";
	my $in = <STDIN>;
	chomp($in);
	warn "## prompt got: $in\n" if $self->debug;
	$in ||= $last;
	$last = $in;
	return ( $in, split(/\s+/, $in) ) if $in;
}

=head2 cli

  $emu->cli();

=cut

my $show_R = 0;

sub cli {
	my $self = shift;
	my $a = $PC || confess "no pc?"; 
	my $run_for = 0;
	warn $self->dump_R() if $show_R;
	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
		my $c = shift @v;
		next unless defined($c);
		my $v = shift @v;
		$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
		@v = map { hex($_) } @v;
		printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
		if ( $c =~ m/^[qx]/i ) {
			exit;
		} elsif ( $c eq '?' ) {
			my $t = $self->trace ? 'on' : 'off' ;
			my $d = $self->debug ? 'on' : 'off' ;
			warn <<__USAGE__;
Usage:

x|q\t\texit
e 6000 6010\tdump memory, +/- to walk forward/backward
m 1000 ff 00\tput ff 00 on 1000
j|u 1000\t\tjump (change pc)
r 42\t\trun 42 instruction opcodes
t\t\ttrace [$t]
d\t\tdebug [$d]

__USAGE__
			warn $self->dump_R;
			$last = '';
		} elsif ( $c =~ m/^e/i ) {
			$a = $v if defined($v);
			my $to = shift @v;
			$to = $a + 32 if ( ! $to || $to <= $a );
			$to = 0xffff if ( $to > 0xffff );
			my $lines = int( ($to - $a + 8) / 8 );
			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
			while ( --$lines ) {
				print $self->hexdump( $a );
				$a += 8;
			}
			$last = '+';
			$show_R = 0;
		} elsif ( $c =~ m/^\+/ ) {
			$a += 8;
			$show_R = 0;
		} elsif ( $c =~ m/^\-/ ) {
			$a -= 8;
			$show_R = 0;
		} elsif ( $c =~ m/^m/i ) {
			$a = $v if defined($v);
			$self->poke_code( $a, @v );
			printf "poke %d bytes at %04x\n", $#v + 1, $a;
			$last = '+';
			$show_R = 0;
		} elsif ( $c =~ m/^l/i ) {
			my $to = shift @v || 0x1000;
			$a = $to;
			$self->load_image( $v, $a );
			$last = '';
		} elsif ( $c =~ m/^s/i ) {
			$self->save_dump( $v || 'mem.dump', @v );
			$last = '';
		} elsif ( $c =~ m/^re/i ) { # reset
			M6502::reset();
			$last = 'r 1';
		} elsif ( $c =~ m/^r/i ) {	# run
			$run_for = $v || 1;
			print "run_for $run_for instructions\n";
			$show_R = 1;
			last;
		} elsif ( $c =~ m/^(u|j)/i ) {
			my $to = $v || $a;
			printf "set pc to %04x\n", $to;
			$PC = $to;	# remember for restart
			$run_for = 1;
			$last = "r $run_for";
			$show_R = 1;
			last;
		} elsif ( $c =~ m/^tape/ ) {
			if ( $c =~ m/rate/ ) {
				$self->tape_rate( $v );
				warn "will read table with rate $v\n";
			} elsif ( ! $v ) {
				warn "ERROR: please specify tape name!\n";
			} elsif ( ! -e $v ) {
				warn "ERROR: tape $v: $!\n";
			} else {
				$self->load_tape( $v );
			}
			$last = '';
		} elsif ( $c =~ m/^t/i ) {
			$self->trace( not $self->trace );
			print "trace ", $self->trace ? 'on' : 'off', "\n";
			$last = '';
		} elsif ( $c =~ m/^d/i ) {
			$self->debug( not $self->debug );
			print "debug ", $self->debug ? 'on' : 'off', "\n";
			$last = '';
		} else {
			warn "# ignored $line\n" if ($line);
			$last = '';
		}
	}

	return $run_for;
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 BUGS

=head1 ACKNOWLEDGEMENTS

See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
info about this machine (and even hardware implementation from 2007).

=head1 COPYRIGHT & LICENSE

Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Orao