#!/usr/bin/perl
#
# $Id: 40seives.pl,v 4.8 2001/11/26 19:56:21 kono Exp $

package StackCardPile;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader TempCardPile);

@EXPORT = qw( );

$VERSION = "0.2";

use Tk;
use Carp;
use CardPlay::Card;
use CardPlay::CardPile;
use CardPlay::CardBoard;

sub new {
    my $type = shift;
    my $self = CardPlay::CardPile->new(@_);
    $self->{'-splitable'}=1;
    $self->{'-mergeable'}=1;
    $self->{'-deltay'}=0;
    $self->{'-deltax'}=$CardPlay::Card::deltax / 2;
    bless $self;
}

sub can_split {
    my ($self,$i) = @_;
    my (@contents) = @{$self->{'-contents'}};
    return 0 if (!defined($contents[$i]));
    return 0 if ($#contents != $i);
    return 1;
}

sub can_merge {
    my ($self,$cardpile) = @_;
    # check for intelligent move only
    if ($self eq $cardpile->{'-prevSplit'}) {
	return $self->intelligent($cardpile); 
    }
    return 0; 
}

# 

package DealCardPile;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader CardPlay::CardPile);

@EXPORT = qw( );

$VERSION = "0.2";

use Tk;
use Carp;
use CardPlay::Card;
use CardPlay::CardPile;
use CardPlay::CardBoard;

sub new {
    my $type = shift;
    my $self = CardPlay::CardPile->new(@_);
    $self->{'-deltay'}=0;
    $self->{'-deltax'}=0;
    bless $self;
    $self->bind('<1>' => sub {$self->deal()});
    $self;
}

sub deal {
    my $self = shift;
    my $i = $self->{'-stackPile'};
    $self->{'-board'}->log_commit(0);
    $i->do_merge($self->do_split(-1));
    $self->auto_play();
}

# 

package TempCardPile;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader CardPlay::CardPile);

@EXPORT = qw( );

$VERSION = "0.2";

use Tk;
use Carp;
use CardPlay::Card;
use CardPlay::CardPile;
use CardPlay::CardBoard;

sub new {
    my $type = shift;
    my $self = CardPlay::CardPile->new(@_);
    $self->{'-mergeable'}=1;
    $self->{'-splitable'}=1;
    $self->{'-deltay'}=$CardPlay::Card::deltax;
    bless $self;
}

sub can_merge {
    my ($self,$cardpile) = @_;
    my ($card) = $cardpile->first();
    my ($last) = $self->last();
    my $vacancy = $self->{'-board'}->tmp_vacancy();
    if (!defined($card)) { 
	return 0; 
    }
    if ($self eq $cardpile->{'-prevSplit'}) {
	# is anywhere better?
	my $ret = $self->intelligent($cardpile); 
	return $ret if ($ret);
    }
    if ($last->{'-state'} eq 'hide') { 
	return $self->intelligent($cardpile); 
    }
    if ($#{$cardpile->{'-contents'}}!=0 
		&& $vacancy <= $#{$cardpile->{'-contents'}}+1) {
	# Too pesimistic. If doubt use one by one move.
	return 0;
    }
    if ($self->empty()) {
	return 1;
    }
    if ($card->{'-number'}==$last->{'-number'}-1 
	&& $card->{'-suit'} eq $last->{'-suit'}  )  {
	return 1; 
    }
    return $self->intelligent($cardpile); 
}

sub intelligent {   # intelligent? Ha!
    my ($self,$cardpile) = @_;
    # remember this is called from can_merge. 
    # use do_merge for undo logging etc.
    my ($suit) = $cardpile->last()->{'-suit'};
    my ($number) = $cardpile->last()->{'-number'};
    my ($last);
    my $vacancy = $self->{'-board'}->tmp_vacancy();
    foreach my $i ( @{$self->{'-finishPiles'}} ) {
        next if ($i eq $self);
        next if ($i->empty);
        $last = $i->last();
        next if ($last->{'-suit'} ne $suit);
        next if ($last->{'-number'} != $number-1);
        $i->do_merge($cardpile);
        return 2;
    }
    if ($#{$cardpile->{'-contents'}}!=0 
		&& $vacancy <= $#{$cardpile->{'-contents'}}+1) {
	# Too pesimistic. If doubt use one by one move.
	return 0;
    }
    $suit = $cardpile->first()->{'-suit'};
    $number = $cardpile->first()->{'-number'};
    foreach my $i ( @{$self->{'-tempPiles'}} ) {
        next if ($i eq $self);
        next if ($i->empty);
        $last = $i->last();
        next if ($last->{'-suit'} ne $suit);
        next if ($last->{'-number'} != $number+1);
        $i->do_merge($cardpile);
        return 2;
    }
    foreach my $i ( @{$self->{'-tempPiles'}} ) {
        next if ($i eq $self);
        next if (! $i->empty);
        $i->do_merge($cardpile);
        return 2;
    }
    return 0;
}

sub can_split {
    my ($self,$i) = @_;
    my (@contents) = @{$self->{'-contents'}};
    my ($ret) = 1;

    if (!defined($contents[$i])) {
	return 0;
    }
    my $suit = $contents[$i]->{'-suit'};
    my $number = $contents[$i]->{'-number'};
    if ($contents[$i]->{'-state'} eq 'hide') {
	return 0;
    } else {
	for(;$i<=$#contents;$i++) {
	    $ret = 0 if (!defined($contents[$i]));
	    $ret = 0 if ($contents[$i]->{'-suit'} ne $suit);
	    $ret = 0 if ($contents[$i]->{'-number'} != $number);
	    return 0 if ($ret==0);
	    $number--;
	}
	return 1;
    }
}


# 

package FinishCardPile;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader CardPlay::CardPile);

@EXPORT = qw( );

$VERSION = "0.2";

use Tk;
use Carp;
use CardPlay::Card;
use CardPlay::CardPile;
use CardPlay::CardBoard;

sub new {
    my $type = shift;
    my $self = CardPlay::CardPile->new(@_);
    $self->{'-reverse_merge'}=1;
    $self->{'-mergeable'}=1;
    $self->{'-deltax'}=0;
    $self->{'-deltay'}=0;
    bless $self;
}

sub can_merge {
    my ($self,$cardpile) = @_;
    my (@contents) = @{$cardpile->{'-contents'}};
    return 0 if ($cardpile->empty());
    if ($self->empty()) {
	return 0 if ($contents[0]->{'-number'} != 1);
	return 1;
    }
    my $suit = $self->last()->{'-suit'};
    my $number = $self->last()->{'-number'}+1;
    for(my $i=$#contents;$i>=0;$i--) {
	return 0 if (!defined($contents[$i]));
	return 0 if ($contents[$i]->{'-suit'} ne $suit);
	return 0 if ($contents[$i]->{'-number'} != $number);
	$number++;
    }
    return 1;
}

# end

package SeivesBoard;
use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
    @count
);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader CardPlay::CardBoard);

@EXPORT = qw( );

$VERSION = "0.2";

use Tk;
use Carp;
use CardPlay::Card;
use CardPlay::CardPile;
use CardPlay::CardBoard;

sub new {
    my $type = shift;
    my $self = CardPlay::CardBoard->new(@_);
    $self->{'-auto_play'} = 1;
    bless $self;
}

sub auto_play {
    my ($self) = @_;
    my ($done) = 1;
    my ($cardpile);
    my ($finish);
    my ($card);
    my ($dest);
    my ($c) = $self->{'-tempPiles'}->[0]->{'-canvas'};
    my (@piles) = (@{$self->{'-tempPiles'}},
	$self->{'-stackPile'},$self->{'-dealPile'});

    retry: while ($done) {
	$done = 0;
	foreach $cardpile (@piles) {
	    $card = $cardpile->last;
	    next if ($card->{'-number'} != 1);
	    foreach $finish (@{$self->{'-finishPiles'}}) {
		next if (! $finish->empty);
		$finish->do_merge($cardpile->do_split(-1));
		$done=1;
		next retry;
	    }
	}
    }
    $done=1;
    retry: while ($done) {
	$done = 0;
	foreach $cardpile (@piles) {
	    $card = $cardpile->last;
	    next if (! defined($card));
	    foreach $finish (@{$self->{'-finishPiles'}}) {
		# first card must be a manual
		$dest = $finish->last;
		next if ($dest->{'-suit'} ne $card->{'-suit'});
		next if ($dest->{'-number'} < $card->{'-number'});
		foreach $finish (@{$self->{'-finishPiles'}}) {
		    # second one can be automatic
		    $dest = $finish->last;
		    next if ($dest->{'-suit'} ne $card->{'-suit'});
		    next if ($dest->{'-number'} != $card->{'-number'}-1);
		    $finish->do_merge($cardpile->do_split(-1));
		    $done=1;
		    $c->update;
		    next retry;
		}
		last;
	    }
	}
    }
    return;
}

sub tmp_vacancy {
    my ($self) = @_;
    my ($i) = 1;
    foreach my $j ( @{$self->{'-tempPiles'}} ) {
	$i++ if ($j->empty);
    }
    return $i;
}

sub new_cards {
    my $self = shift;
    my $card = [];
    my ($i,$j,$suit);
    my ($c) = $self->{'-canvas'};

    for($j=0;$j<2;$j++) {
	foreach $suit ( 's','h','c','d') {
	    for($i=1;$i<14;$i++) {
		push(@{$card},CardPlay::Card->new(
			-state=>'open',
			-canvas=>$c,-board=>$self,-suit=>$suit,-number=>$i));
	    }
	}
    }
    $self->{'-cards'} = $card;
    $self;
}

@count = (4,4,4,4,4,4,4,4,4,4);

sub display {
    my $self = shift;
    $self->SUPER::display( -title=>'40Seives');
    my $c = $self->{'-canvas'};
    my $x = $CardPlay::Card::cx+10; 
    my $y = 20;
    my @finish;
    my @cp;
    my $i;
	
    $self->{'-mainWindow'}->geometry(
	sprintf("%dx%d",
	    ($CardPlay::Card::cx+6)*10,
	    ($CardPlay::Card::cy)*7
	));
    $self->new_cards;

    for($i=0;$i<8;$i++) {
	$finish[$i] = FinishCardPile->new(-canvas=>$c,-base=>1,-board=>$self);
	$finish[$i]->display('-x'=>$x,'-y'=>$y);
	$x += $CardPlay::Card::cx+5; 
    }
    $self->{'-finishPiles'} = \@finish;
    $self->add_piles(@finish);

    $x = 5;
    $y = $y+10+$CardPlay::Card::cy; 

    my $dl = DealCardPile->new(-canvas=>$c,-board=>$self,-base=>1);
    $self->{'-dealPile'} = $dl;
    $dl->display(-x=>$x,-y=>$y);
    $self->add_piles($dl);

    $x = $x+10+$CardPlay::Card::cx; 
    my $stack = StackCardPile->new(
	-canvas=>$c,-base=>1,-board=>$self,
	-finishPiles=>\@finish,
	-tempPiles=>\@cp);
    $stack->display('-x'=>$x,'-y'=>$y);
    $self->{'-stackPile'} = $stack;
    $dl->{'-stackPile'} = $stack;
    $self->add_piles($stack);

    $x = 5; 
    $y += $CardPlay::Card::cy+10;

    for($i=0;$i<=$#count;$i++) {
	$cp[$i] = TempCardPile->new(
				    -canvas=>$c,-board=>$self,
				    -finishPiles=>\@finish,
				    -tempPiles=>\@cp);
	$cp[$i]->display('-x'=>$x,'-y'=>$y,-base=>1);
	$x += $CardPlay::Card::cx+5;
    }

    $self->{'-tempPiles'} = \@cp;
    $self->add_piles(@cp);

    $self;
}

sub setup {
    my $self = shift;

    my ($dl) = $self->{'-dealPile'};
    my ($cp) = $self->{'-tempPiles'};
    my ($sk) = $self->{'-stackPile'};
    my ($fi) = $self->{'-finishPiles'};
    my ($i,$j);

    # remove all CardPile
    $self->clear;
    # make new board by saved card array
    @{$dl->{'-contents'}} = @{$self->{'-cards'}}; # copy
    for($i=0;$i<=$#count;$i++) {
	$cp->[$i]->merge($dl->split(- $count[$i]));
    }

    $self;
}

# end

package main;

use strict;
use CardPlay::CardBoard;

my $board = SeivesBoard->new();

$board->game();

1;

# end