#!/usr/bin/perl -w
# 作者: 洪朝貴 http://www.cyut.edu.tw/~ckhung/
# 功能: 讓使用者下跳棋的程式. 純粹只是版面安排及棋子移動;
#       沒有電腦下棋的功能.
# 需求: perl-Tk 模組.
# 命令列選項:
#	-n grid_count (每一國有多少格寬)
#	-s grid_size (每一格有多寬)
# 版權聲明: XFree86 style. 如果您要將我的程式改寫成有用的大程式,
#	    建議將您的版本施以 GPL

use Getopt::Std;
use Tk;
use Tk::Dialog;
use Tk::DialogBox;
use POSIX qw(floor);
use Data::Dumper;
use strict;

use vars qw($board $pos);
# 用 my 宣告的變數無法跨越檔案

my (
#    $board,		# 棋盤外觀
#    $pos,		# 棋子的位置. 只有讀寫檔案時用得到.
    %opts,		# 選項    
    $main,              # 主視窗
    $dir,               # (六個)方向
    $picked,            # 目前撿起來的棋子
    $chess_id,		# 棋子的 id
    @tri_id,            # 六片三角形的 id
    $file_name,         # 檔案名稱
    $chess_moved,	# 棋子移動過了嗎?
);

# 設定棋盤外觀
getopts('n:s:', \%opts);
$board = {
    color => ["red", "blue", "yellow"],
    grid_count => $opts{n} || 3,
    grid_size => $opts{s} || 20,
};
# 建立主視窗及選單
$main = MainWindow->new();
$main->protocol("WM_DELETE_WINDOW", \&on_quit);
$main->{menubar} = $main->Frame(-relief=>"raised", -bd=>2);
$main->{menubar}->pack(-side=>"top", -fill=>"both");
$main->{status} = $main->Frame(-relief=>"sunken", -bd=>2);
$main->{status}->pack(-side=>"bottom", -fill=>"both");
$main->{worksp} = $main->Canvas(-bg=>"white");
$main->{worksp}->pack(-side=>"top", -fill=>"both", -expand=>"yes");
$main->{menubar}{file} = $main->{menubar}->Menubutton(
    -text=>"File", -tearoff=>0, -menuitems=>[
        ["command"=>"Open", -command=>\&on_open],
        ["command"=>"Save", -command=>\&on_save],
        ["command"=>"Print (to file as eps)", -command=>\&on_print],
        "-",
        ["command"=>"Quit", -command=>\&on_quit]
    ]
);
$main->{menubar}{file}->pack(-side=>"left", -fill=>"both");

$file_name = $chess_moved = "";
$picked = 0;
if ($ARGV[0] && -r $ARGV[0]) {
    &on_open($ARGV[0]);
} else {
    &rebuild();
}
$main->{worksp}->bind("chess", '<Button>',
    [\&on_pick, Ev('b'), Ev('x'), Ev('y')]);
$main->{worksp}->CanvasBind('<Motion>', [\&on_motion, Ev('x'), Ev('y')]);
MainLoop();

#=================================================================

use vars qw($unitvec);

# 建立六個方向的單位向量
BEGIN {
    my ($th) = atan2(1,1)*4/3;
    for (my $i=0; $i<=6; ++$i) {
	$unitvec->[$i] = [cos($th*$i), sin($th*$i)];
    }
}

# 棋盤座標轉換成畫布座標
sub pq2xy {
    my ($p, $q, $dir) = @_;
    $dir = 0 unless defined $dir;
    my ($x, $y) = (
	$p*$unitvec->[$dir][0]+$q*$unitvec->[$dir+1][0],
	$p*$unitvec->[$dir][1]+$q*$unitvec->[$dir+1][1]
    );
    return (
	$x*$board->{grid_size}+$board->{width}/2,
	$board->{height}/2-$y*$board->{grid_size}
    );
}

# 畫布座標轉換成棋盤座標
sub xy2pq {
    my ($x, $y) = @_;
    ($x, $y) = (
	($x-$board->{width}/2)/$board->{grid_size},
	($board->{height}/2-$y)/$board->{grid_size},
    );
    my ($det) = $unitvec->[0][0]*$unitvec->[1][1]
	      - $unitvec->[0][1]*$unitvec->[1][0];
    return ( floor(($x*$unitvec->[1][1] - $y*$unitvec->[1][0])/$det + 0.5),
	     floor(($y*$unitvec->[0][0] - $x*$unitvec->[0][1])/$det + 0.5));
}

# (針對圓圓的棋子設計的函數) 由棋盤座標計算出棋子的左上角與右下角畫布座標
sub pq2chess {
    my ($p, $q, $dir) = @_;
    my ($s) = $board->{grid_size}*0.35;
    my ($x, $y) = pq2xy($p, $q, $dir);
    return ($x-$s, $y-$s, $x+$s, $y+$s);
}

# (針對圓圓的棋子設計的函數) 由棋子的左上角與右下角畫布座標計算出棋盤座標
sub chess2pq {
    my ($xms, $yms, $xps, $yps) = @_;
    return xy2pq(($xms+$xps)/2, ($yms+$yps)/2);
}

sub rebuild {
    my ($i, $j);
    $board->{width} = $board->{grid_count}*$board->{grid_size}*3 + 50;
    $board->{height} = $board->{grid_count}*$board->{grid_size}*sqrt(3)*2 + 50;
    $main->{worksp}->configure(-width=>$board->{width},
	-height=>$board->{height});
    $main->{worksp}->delete("all");
    # 六側各國領土
    foreach $dir (0..5) {
	$tri_id[$dir] = $main->{worksp}->createPolygon(
	    pq2xy($board->{grid_count}, 0, $dir),
	    pq2xy($board->{grid_count}, $board->{grid_count}, $dir),
	    pq2xy(0, $board->{grid_count}, $dir),
	);
    }
    # 棋盤
    foreach $dir (0..5) {
	foreach $i (1..$board->{grid_count}-1,
	    $board->{grid_count}*2..$board->{grid_count}*3) {
	    $main->{worksp}->createLine(
		pq2xy($board->{grid_count}, $board->{grid_count}-$i, $dir),
		pq2xy($board->{grid_count}-$i, $board->{grid_count}, $dir)
	    );
	}
    }
    # 棋子
    $chess_id = [];
    foreach $dir (0, 2, 4) {
	foreach $i (0..$board->{grid_count}) {
	    foreach $j (0..$i) {
		my $c = $main->{worksp}->createOval(
		    pq2chess(
			$board->{grid_count}-$i+$j,
			$board->{grid_count}-$j, $dir
		    ),
		    -tags=>"chess"
		);
		push @{$chess_id->[$dir % 3]}, $c;
	    }
	}
    }
    & paint_color();
}

sub paint_color {
    my ($i);
    for ($i=0; $i<6; ++$i) {
	$main->{worksp}->itemconfigure($tri_id[$i],
	    -fill=>$board->{color}[$i%3]);
    }
    for ($i=0; $i<3; ++$i) {
	foreach (@{$chess_id->[$i]}) {
	    $main->{worksp}->itemconfigure($_, -fill=>$board->{color}[$i]);
	}
    }
}

# 使用者撿起或放下棋子
sub on_pick {
    my ($canvas, $button, $x, $y) = @_;
    if ($picked) {
	$picked = 0;
	$chess_moved = "*";
	return;
    } else {
	return unless $button == 1;
	$picked = $canvas->find("withtag", "current");
	$canvas->raise($picked);
    }
}

# 使用者移動棋子
sub on_motion {
    return unless $picked;
    my ($canvas, $x, $y) = @_;
    # 強迫棋子落在格子點上
    $canvas->coords($picked, pq2chess(xy2pq($x, $y)));
}

sub on_save {
    foreach (@$chess_id) {
	push @$pos, [map [
	    chess2pq($main->{worksp}->coords($_))
	], @$_];
    }
    my ($fn);
    return unless $fn = $_[0] || $main->getSaveFile(
	-title=>"Save chessboard as...",
    );
    $Data::Dumper::Terse = 1;
    open F, "> $fn" or die "can't open $fn for writing";
    print F '$board = ', Dumper($board), ";\n",
	'$pos = ', Dumper($pos), ";\n";
    close F;
    $file_name = $fn;
    $chess_moved = "";
}

sub on_open {
    if ($chess_moved) {
	my ($ans) = $main->messageBox(-title=>"save old", -type=>"YesNoCancel",
	    -message=>"Chess may have been moved."
	    . "Save old chessboard before opening a new one?"
	);
	return if $ans eq "Cancel";
	on_save if $ans eq "Yes";
    }
    my ($fn);
    return unless $fn = $_[0] || $main->getOpenFile(
	-title=>"Load chessboard from...",
    );
    do $fn or die "can't open $fn for reading";
    # "require" won't work because it tries to avoid repeated loading.
    &rebuild();
    my ($i, $j);
    for ($i=0; $i<=$#$chess_id; ++$i) {
	for ($j=0; $j<=$#{$chess_id->[$i]}; ++$j) {
	    $main->{worksp}->coords($chess_id->[$i][$j],
		pq2chess(@{$pos->[$i][$j]})
	    );
	}
    }
    $file_name = $fn;
    $chess_moved = "";
}

sub on_print {
    my ($fn);
    return unless $fn = $_[0] || $main->getSaveFile(
	-title=>"Print chessboard (as eps) to...",
    );
    $main->{worksp}->postscript(-file=>$fn);
}

sub on_quit {
    exit if ! $chess_moved;
    my ($ans) = $main->messageBox(-title=>"quit", -type=>"YesNoCancel",
        -message=>"Chess may have been moved. Save chessboard before quitting?",
    );
    return if $ans eq "Cancel";
    on_save if $ans eq "Yes";
    exit;
}