Games::Cards::Tk - Package to write Tk ports for Games::Cards card games

    use Games::Cards;
    use Games::Cards::Tk;

    # Create a canvas and print background etc.
    $My_Game->set_canvas($c); # my game will use canvas $c

    # ... do lots of things you do in Games::Cards anyway
    # Cards' Tk images will be moved automatically!
    $Stock->give_cards($Waste, 3);

    # Mark clicked card
    $card = $My_Game->get_card_by_tag("current");
    $card->mark;

package Games::Cards::Tk;
# Pieces of this came from the freecell.tk that Michael Houghton sent me

use strict;

{
package Games::Cards::Tk::Game;
@Games::Cards::Tk::Game::ISA = qw (Games::Cards::Game);

sub card_width { shift->{"card_width"} }
sub card_height { shift->{"card_height"} }

sub load_card_images {

    my $image_dir = Tk::findINC("Games/Cards/images/");

    my $self = shift;
    my $canvas = $self->canvas;

    # Oxymoron's images are stored as two-char names.
    # First letter is [1-9tjqka], second is [cdhs]
    my %name_hash = (
	"Ace" => "a",
	10 => "t",
	"Jack" => "j",
	"Queen" => "q",
	"King" => "k",
    );

    # Load each card image
    my $im;
    foreach my $suit (@{$self->{"suits"}}) {
	my $s = substr($suit,0,1);
	foreach my $name (keys %{$self->{"cards_in_suit"}}) {
	    my $n = exists $name_hash{$name} ? $name_hash{$name} : $name;
	    my $f = $n . lc($s);
	    $im = $canvas->Photo(-file => "$image_dir/$f.gif");
	    my $key = $name.$suit;
	    $self->{"card_images"}->{$key} = $im;
	}
    }

    $im = $canvas->Photo(-file => "$image_dir/b.gif");
    $self->{"card_images"}->{"back"} = $im;
    $self->{"card_width"}  = $im->width;
    $self->{"card_height"} = $im->height;
}

sub card_image {
    my ($self, $card) = @_;
    if (ref($card)) {
	my $key = $card->name("long") . $card->suit("long");
	if (exists ($self->{"card_images"}->{$key})) {
	    return $self->{"card_images"}->{$key};
	} else {
	    return undef;
	}
    } else {
        return undef unless $card eq "back";
	return $self->{"card_images"}->{"back"};
    }
}

sub get_card_by_tag {
    my ($self, $tag) = @_;
    my $canvas = $self->canvas;
    my @ids = $canvas->find(withtag => $tag);
    # Find cardfront: or cardback: tag for each Id
    my @cards = grep /^card(back|front):/, map {$canvas->gettags($_)} @ids;

    if (@cards) {
	# TODO in fact, maybe we should allow multiple cards
	# Actually, this will probably break if front & back have the tag!
	warn "too many cards!" if @cards > 1;
	my $tag = $cards[0];
	$tag =~ s/^card(front|back)://;
	my $card = $self->get_card_by_truename($tag);
	return $card;
    } else {
        return undef;
    }
}

sub get_cardset_by_tag {
    my ($self, $tag) = @_;
    my $canvas = $self->canvas;
    my @ids = $canvas->find(withtag => $tag);
    my @sets = grep /^set:/, map {$canvas->gettags($_)} @ids;

    if (@sets) {
	warn "too many sets!" if @sets > 1;
	my $tag = $sets[0];
	$tag =~ s/^set://;
	my $card = $self->get_cardset_by_name($tag);
	return $card;
    } else {
    print "help!\n";
        return undef;
    }
}

sub get_marked_card {
    my $self = shift;
    my $tag = "marked";
    return $self->get_card_by_tag($tag);
}

sub get_clicked_cardset {
    my $self = shift;
    my $tag = "current";
    if (defined (my $card = $self->get_card_by_tag($tag))) {
        return $card->owning_cardset;
    } else {
	return $self->get_cardset_by_tag($tag);
    }
}

sub canvas { return shift->{"canvas"}; }
sub set_canvas {
    my ($game, $canvas) = @_;
    $game->{"canvas"} = $canvas;
}


} # end package Games::Cards::Tk::Game

###############################################################################

{
package Games::Cards::Tk::Card;
@Games::Cards::Tk::Card::ISA = qw(Games::Cards::Card);

sub face_up {
    my $self = shift;
    $self->SUPER::face_up; # do GC::Card::face_up stuff
    $self->redraw;
}

sub face_down {
    my $self = shift;
    $self->SUPER::face_down; # do GC::Card::face_up stuff
    $self->redraw;
}

# A tag that's guaranteed to return just one card (and its back!)
sub Tk_truename {
    my $self = shift;
    return "card:" . $self->truename;
}
# A tag that's guaranteed to return just one card front
sub Tk_truename_front {
    my $self = shift;
    return "cardfront:" . $self->truename;
}
# A tag that's guaranteed to return just one card back
sub Tk_truename_back {
    my $self = shift;
    return "cardback:" . $self->truename;
}
    
    

sub draw {
    my $card = shift;
    my @tags;
    my $cname = $card->Tk_truename;
    push @tags, "card", $cname;

    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    my $id = $canvas->createImage(
	0,0,
	-anchor => 'nw', 
	-image  => $game->card_image($card),
	-tags => [@tags, "cardfront", $card->Tk_truename_front],
    );

    # now create back of card
    $id = $canvas->createImage(
	0,0,
	-anchor => 'nw', 
	-image  => $game->card_image("back"),
	-tags => [@tags, 'cardback', $card->Tk_truename_back],
    );
} # end sub Games::Cards::Tk::Card::draw
	

sub mark {
    my $self = shift;
    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    # Mark front or back of card, whichever's showing. (The front & back
    # are guaranteed to be in the same place. This just makes it easier
    # for clicking & stuff.)
    my $cname = $self->is_face_up ? 
        $self->Tk_truename_front :
        $self->Tk_truename_back; 
    $canvas->addtag("marked", withtag => $cname);

    # Put a rectangle around the marked card
    $canvas->createRectangle($canvas->bbox($cname),
        -outline => "black",
	-width => 3,
	-tags => ["outline"],
    );
    #$canvas->itemconfigure($cname, -fill => '#dddddd');
}

sub unmark {
    my $self = shift;
    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    my $cname = $self->is_face_up ? 
        $self->Tk_truename_front :
        $self->Tk_truename_back; 
    $canvas->dtag($cname, "marked");
    # TODO if we can select > 1 card, this will be wrong
    $canvas->delete("outline");
}

sub place {
    my ($self, $x, $y) = @_;
    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    my $cardid = $self->Tk_truename;
    my @fromloc = $canvas->bbox($cardid);
    $canvas->move($cardid, $x-$fromloc[0], $y-$fromloc[1]); 
    $canvas->Subwidget("canvas")->raise($cardid);
}

sub redraw {
    my $self = shift;
    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    # We might call this method before even creating a canvas. E.g., it
    # gets called by face_up, which might be called during game init.
    return unless defined $canvas;
    # Should card front or back be on top?
    my ($front, $back) = ($self->Tk_truename_front, $self->Tk_truename_back);
    my @order = $self->is_face_up ? ($front, $back) : ($back, $front);
    $canvas->Subwidget("canvas")->raise(@order);
}

} # end package Games::Cards::Tk::Card

###############################################################################

{
package Games::Cards::Tk::Deck;
@Games::Cards::Tk::Deck::ISA =
    qw (Games::Cards::Tk::Queue Games::Cards::Deck);

# This is terrible coding! However, I need to make ISA have Tk methods first,
# so that we try using Tk methods before others. Yet, we *don't* want to
# use GC::Tk::Queue::new. Nonetheless, there's probably a better way to do it.
sub new {
    Games::Cards::Deck::new(@_);
}
} # end package Games::Cards::Tk::Deck

{
package Games::Cards::Tk::CardSet;
@Games::Cards::Tk::CardSet::ISA = qw(Games::Cards::CardSet);

# Extra fields for Tk CardSets
#
sub new {
    my $a = shift;
    my $class = ref($a) || $a;
    (my $non_Tk = $class) =~ s/Tk::// or die "weird class $class!\n";
    my $self = $non_Tk->new(@_); # Call the non-Tk new sub

    # Now add some Tk attributes
    $self->{"delta_x"} = 0;
    $self->{"delta_y"} = 0;
    $self->{"border_x"} = 0;
    $self->{"border_y"} = 0;

    # Now bless it to the Tk class
    bless $self, $class;
}

sub attributes {
    my $self = shift;
    # Attributes that may be changed by this sub
    my @_changeable = qw (delta_y delta_x border_x border_y);
    my $aref = shift;
    foreach my $att (keys %$aref) {
        if (grep {$att eq $_} @_changeable) {
	    $self->{$att} = $aref->{$att};
	} else {
	    warn "not allowed to change attribute $att";
	}
    }
}

# TODO alternatively, just draw *cards* that need to be redrawn?
sub redraw {
    my $self = shift;

    my $game = &Games::Cards::Game::current_game;
    my $canvas = $game->canvas;
    # redraw gets called by give_cards, which may be called during initial
    # setup before you've created the canvas. In that case, obviously
    # you can't redraw, and in fact, it will cause errors to try.
    return unless defined $canvas;

    my $name = $self->name;
    my $delta_y = $self->{"delta_y"};
    my $delta_x = $self->{"delta_x"};
    my $border_y = $self->{"border_y"};
    my $border_x = $self->{"border_x"};
    my ($x, $y) = $canvas->coords("set:$name"); 
    $x += $border_x;
    $y += $border_y;
    foreach my $card (@{$self->cards}) {
	$card->place($x, $y);
	$card->redraw;
	#$card->change_set($canvas, $name); # in case it has moved
	$y += $delta_y;
	$x += $delta_x;
    }
}

# Act just like Games::Cards::CardSet::splice but add Tk stuff
sub splice {
    my ($set, $offset, $length, $in_cards) = @_;
    shift; # shift out $set for SUPER call
    my $out_cards = $set->SUPER::splice(@_);

    # Splice is called twice: for splicing out & in, so we'll end up
    # redrawing the giving & receiving set.
    $set->redraw; 

    return $out_cards;
} # end sub Cards::Games::splice

} # end package Games::Cards::Tk::CardSet

###############################################################################
# Declare Tk subclass for each non-Tk Games::Cards class
{
# Note that non-Tk SUPER comes first, so that SUPER methods will use Tk
# parent classes if they exist
package Games::Cards::Tk::Queue;
@Games::Cards::Tk::Queue::ISA =
    qw (Games::Cards::Tk::Pile Games::Cards::Queue);

package Games::Cards::Tk::Stack;
@Games::Cards::Tk::Stack::ISA =
    qw (Games::Cards::Tk::Pile Games::Cards::Stack);

package Games::Cards::Tk::Pile;
@Games::Cards::Tk::Pile::ISA =
    qw (Games::Cards::Tk::CardSet Games::Cards::Pile);

package Games::Cards::Tk::Hand;
@Games::Cards::Tk::Hand::ISA =
    qw (Games::Cards::Tk::CardSet Games::Cards::Hand);
}

# return true to caller
1;