use Prima 'MsgBox', 'Application';

=pod

=head1 NAME

examples/amba.pl - A chess puzzle

=head1 FEATURES

Demonstrates custom pointer creation

=cut

use strict;
use warnings;

# binhex and rle crunched data from 5 40x40 1-bit images
my $d = <<DATA;
rrrrrj1w8l1w8l1w8l1w8l1w8jj1w8l1w8mwnwn7uekk3uen3ucn1u8oe7o1e78kk3e7cn7e
7en7e7en6j6n6j6kk7e7en7e7en3e7cn1e78o66ll7epc3pdbpdbp66ll66p3cp18rrlrrrr
k1uckj1wcl7xl67v3l7iu87l7tj7tjj63ue3l78ktl7xl7xlcw98ii1aiu82cj27ej3t2j5u
ebudjbuebue8i3uc9uei17uddv417u94v417ub6v4i7u6b7ujbteebbte8i4t9ddct9j3i65
d3i6kt85dit8m5dp5dll22p1cq8q8q8lm8p3eq8q8rlrrrrk7x8k7we8k7wc8k3wc8k3wc8k
1wc8k1wc8lwc8j4i7vc8i3ei3vcj7ti1vdiitb81vdjdtciv9jcteiv9jcu87u9j7ue7uaii
7v7u2j3y2j3vbu6j1xe4kxe4ijxc8k6wc8k67v9l73vbl79v6jj3vecl3v98l1c7c7nvcm1t
78lj1e78n1c3o1i3rrmrrrk3uemy8ii1yck7x8ky8k7xl23ue2jj7cj1tl7xl7xlc1uc18kt
cj1t8ii1ycj3yej3yej7yej7zii7zj7dtbetdtj79tbetctj79t3e7ctj71t3e7c7iit1t3e
7c78ieie1c3838icie1c3818icie1c381838ic1c18ie7cic1c181t7ci8i8i81t7c1ci81c
1t383e1c3eiej3e3e3ejj3e3e3el1c3e1cn1crrlrrrrri1ycj1ycj1ycj1cl1ck3xjj3xl2
l3l3xl1wemcj18jk7vn7vn7vn7vn7vkk7vn7vn7vn7vn7vkk7vn7vn4j1nwm1wcjrj7xl7xl
7xl7c3e1tjj7c3e1tl7c3e1trrrj
DATA
$d =~ s/\n//g;
$d =~ s/([h-r])/q(0)x(ord($1)-ord('h'))/ge;
$d =~ s/([s-z])/q(f)x(ord($1)-ord('s'))/ge;
$d =~ s/(..)/chr hex qq(0x$1)/ge;
#
my $sc = $::application-> uiScaling;
my @images = map { Prima::Image-> create(
	width    => 40,
	height   => 40,
	type     => im::BW,
	data     => $_,
	lineSize => 5,
) } grep { length } split "(.{200})", $d;

$_->set( size => [ map { $_ * $sc } $_->size ]) for @images;
@images = map { $_-> bitmap } @images;

# figures mnemonic names ( incorrect :)
my %figs = (
	'K' => [0,0],
	'B1' => [0,1],
	'B2' => [0,2],
	'Q'  => [0,3],
	'T1' => [0,4],
	'T2' => [0,5],
	'R1' => [0,6],
	'R2' => [0,7],
);

my %images = (
	'K'  => $images[1],
	'B1' => $images[0],
	'B2' => $images[0],
	'Q'  => $images[3],
	'T1' => $images[4],
	'T2' => $images[4],
	'R1' => $images[2],
	'R2' => $images[2],
);

# colors shade the degree of fugure coverage
my @colors = (
	0x808080,
	0x707070,
	0x606060,
	0x505050,
	0x404040,
	0x303030,
	0x202020,
	0x101010,
	0x000000,
);

my @pointer= map {
	$::application-> get_system_value( $_ )
} sv::XPointer, sv::YPointer;
$pointer[$_] = ( $pointer[$_] - 40 * $sc ) / 2 for 0,1;

my $w = Prima::MainWindow-> create(
	name => 'Chess puzzle',
	size => [ 360 * $sc, 360 * $sc],
	font => { style => fs::Bold, size => 11,},
	buffered => 1,
	menuItems => [
		["~Help" => sub{
			Prima::MsgBox::message(
				'Chess puzzle. Objective is to put figures so they could reach every cell upon the board',
				mb::OK | mb::Cancel,
				buttons => { mb::Cancel , {
					text => '~Solution',
					onClick => sub {
						Prima::MsgBox::message(
							'Use Ctrl + mouse doubleclick on the board ',
							mb::OK
						);
					}
				}}
			);
		}],
	],
	onPaint => sub {
		my $self = $_[0];
		my $i;
		$self-> color( cl::Back);
		$self-> bar ( 0, 0, $self-> size);
		$self-> color( cl::Black);
		my $d = 40 * $sc;
		for ( $i = 0; $i < 9; $i++) {
			$self-> line( $i * $d, 0, $i * $d, $d * 8);
			$self-> line( 0, $i * $d, $d * 8, $i * $d);
		}
		my @boy = (0) x 64;
		my @busy = (0) x 64;
		for ( keys %figs) {
			my ($x,$y) = @{$figs{$_}};
			$busy[$y*8+$x] = 1;
		}
		my $add = sub {
			my ($x,$y) = @_;
			if ( $x >= 0 && $x < 8 && $y >= 0 && $y < 8) {
				$boy[$y*8+$x] += 1;
				return !$busy[$y*8+$x];
			} else {
				return 0;
			}
		};
		for ( keys %figs) {
			my ( $x, $y) = @{$figs{$_}};
			next unless $x >= 0 && $x < 8 && $y >= 0 && $y < 8;
			if ($_ eq 'K') {
				$add-> ($x-1,$y-1);
				$add-> ($x-1,$y);
				$add-> ($x-1,$y+1);
				$add-> ($x,$y-1);
				$add-> ($x,$y+1);
				$add-> ($x+1,$y-1);
				$add-> ($x+1,$y);
				$add-> ($x+1,$y+1);
			} elsif ($_ eq 'Q') {
				for (1..7) { last unless $add-> ($x-$_,$y); }
				for (1..7) { last unless $add-> ($x+$_,$y); }
				for (1..7) { last unless $add-> ($x,$y-$_); }
				for (1..7) { last unless $add-> ($x,$y+$_); }
				for (1..7) { last unless $add-> ($x-$_,$y-$_); }
				for (1..7) { last unless $add-> ($x-$_,$y+$_); }
				for (1..7) { last unless $add-> ($x+$_,$y-$_); }
				for (1..7) { last unless $add-> ($x+$_,$y+$_); }
			} elsif (/^T\d$/) {
				for (1..7) { last unless $add-> ($x-$_,$y); }
				for (1..7) { last unless $add-> ($x+$_,$y); }
				for (1..7) { last unless $add-> ($x,$y-$_); }
				for (1..7) { last unless $add-> ($x,$y+$_); }
			} elsif (/^B\d$/) {
				for (1..7) { last unless $add-> ($x-$_,$y-$_); }
				for (1..7) { last unless $add-> ($x-$_,$y+$_); }
				for (1..7) { last unless $add-> ($x+$_,$y-$_); }
				for (1..7) { last unless $add-> ($x+$_,$y+$_); }
			} elsif (/^R\d$/) {
				$add-> ($x-1,$y-2);
				$add-> ($x-1,$y+2);
				$add-> ($x-2,$y-1);
				$add-> ($x-2,$y+1);
				$add-> ($x+1,$y-2);
				$add-> ($x+1,$y+2);
				$add-> ($x+2,$y-1);
				$add-> ($x+2,$y+1);
			}
		}
		for ( grep $boy[$_], 0..63) {
			my ( $x, $y) = ($_ % 8, int($_/8));
			$self-> color( $colors[$boy[$_]] );
			$self-> bar( $x * $d+1, $y * $d+1, ($x + 1) * $d - 1, ($y + 1 ) * $d - 1);
		}

		for ( keys %figs) {
			my ( $x, $y) = @{$figs{$_}};
			$self-> set(
				color     => cl::White,
				backColor => cl::Black,
				rop       => rop::AndPut,
			);
			$self-> put_image( $x * $d, $y * $d, $images{$_});
			$self-> set(
				color     => cl::Black,
				backColor => $boy[ $y * 8 + $x] ? cl::LightGreen : cl::Green,
				rop       => rop::XorPut,
			);
			$self-> put_image( $x * $d, $y * $d, $images{$_});
		}
	},
	onMouseDown => sub {
		my ( $self, $btn, $mod, $x, $y) = @_;
		return if $self-> {cap};
		my $d = 40 * $sc;
		$x = int( $x / $d);
		$y = int( $y / $d);
		return if $x < 0 || $x > 8 || $y < 0 || $y > 8;
		my $i = '';
		for ( keys %figs) {
			my ( $ax, $ay) = @{$figs{$_}};
			$i = $_, last if $ax == $x and $ay == $y;
		}
		return unless $i;
		$self-> {cap} = $i;
		$self-> capture(1);
		$self-> pointer( cr::Size);
		my $xx = $self-> pointerIcon;

		if ( $::application-> get_system_value( sv::ColorPointer)) {
			$xx->scaling(ist::None);
			my @sz = $images{$i}->size;
			$xx->width($sz[0]) if $xx->width < $sz[0];
			$xx->height($sz[1]) if $xx->height < $sz[1];
		}
		my ( $xor, $and) = $xx-> split;

		$and-> begin_paint;
		$and-> backColor(cl::White);
		$and-> clear;
		$and-> rop( rop::NotSrcAnd);
		$and-> put_image( @pointer, $images{$i});
		$and-> end_paint;

		$xor->type(im::RGB) if $xor->get_bpp == 1 && $::application-> get_system_value( sv::ColorPointer);
		$xor-> begin_paint;
		$xor-> set(
			color      => cl::Black,
			backColor  => $::application-> get_system_value( sv::ColorPointer) ?
					cl::Green : cl::White,
			rop        => rop::OrPut,
		);
		$xor-> put_image( @pointer, $images{$i});
		$xor-> end_paint;

		$xx-> combine( $xor, $and);
		$self-> pointer( $xx);
	},
	onMouseUp => sub {
		my ( $self, $btn, $mod, $x, $y) = @_;
		return unless $self-> {cap};
		my $d = 40 * $sc;
		$x = int( $x / $d);
		$y = int( $y / $d);
		$self-> capture(0);
		$self-> pointer( cr::Default);
		my $fg = $self-> {cap};
		delete $self-> {cap};
		return if $x < 0 || $x > 8 || $y < 0 || $y > 8;
		my $i = '';
		for ( keys %figs) {
			my ( $ax, $ay) = @{$figs{$_}};
			$i = $_, last if $ax == $x and $ay == $y;
		}
		return if $i;
		$figs{$fg} = [ $x, $y];
		$self-> repaint;
	},
	onMouseClick => sub {
		my ( $self, $btn, $mod, $x, $y, $dbl) = @_;
		if ( $dbl and ( $mod & km::Ctrl)) {
			%figs = (
				'K'  => [2,5],
				'B1' => [5,5],
				'B2' => [2,2],
				'Q'  => [5,2],
				'T1' => [7,7],
				'T2' => [0,0],
				'R1' => [4,4],
				'R2' => [3,3],
			);
			$self-> repaint;
		}
	},
);


run Prima;