# # $Id: Card.pm,v 4.10 2002/07/21 06:49:51 kono Exp $ # package CardPlay::Card; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %image $cx $cy %point $size $deltax $deltay ); require Exporter; require AutoLoader; @ISA = qw(Exporter AutoLoader CardPlay::SimpleCard ); @EXPORT = qw( ); $VERSION = "0.2"; use Tk; use Carp; use CardPlay::SimpleCard; %image= (); # class method sub init { my ($type) = shift; my (%arg) = @_; my ($x,$y,$tag,$suit,$w,$b); my ($file,$name); my ($image,$size); srand; if (! defined($arg{'-main'}) ) { carp "${type}::init needs -main\n"; } $w = $arg{'-main'}; if (!defined($arg{'-size'}) ) { $size = 'large' } else { $size = $arg{'-size'} } if ($size eq 'large') { eval ' use CardPlay::LargeCard; ($deltax,$deltay,$cx,$cy) = CardPlay::LargeCard->init($w,\%image); '; } elsif ($size eq 'vlarge' ) { eval ' use CardPlay::VeryLargeCard; ($deltax,$deltay,$cx,$cy) = CardPlay::VeryLargeCard->init($w,\%image); '; } else { eval ' use CardPlay::SmallCard; ($deltax,$deltay,$cx,$cy) = CardPlay::SmallCard->init($w,\%image); '; # print "($deltax,$deltay,$cx,$cy)\n"; } 1; } sub new { my $type = shift; my ($suit,$number,$c); my $self; %$self = @_; if (! defined($self->{'-canvas'}) || ! defined($self->{'-suit'}) || ! defined($self->{'-number'})) { carp "Card needs -canvas,-suit,-number\n"; } defined($self->{'-state'}) or $self->{'-state'} = 'removed'; $c = $self->{'-canvas'}; $suit = $self->{'-suit'}; $number = $self->{'-number'}; $self->{'-image'} = $image{$suit.$number}; bless $self; } sub movable { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($tag) = $self->{'-tag'}; $self->{'-movable'}=1; $c->bind($tag, '<1>' => sub {$self->plot_down(@_)}); $c->bind($tag, '<2>' => sub {$self->hide(@_)}); $c->bind($tag, '<3>' => sub {$self->open(@_)}); $c->bind($tag, '<ButtonRelease-1>' => sub {shift->dtag('selected')}); $c->bind($tag, '<B1-Motion>' => sub {$self->plot_move(@_)}); } sub unmovable { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($tag) = $self->{'-tag'}; $self->{'-movable'}=0; $c->bind($tag, '<1>' => ""); $c->bind($tag, '<2>' => ""); $c->bind($tag, '<3>' => ""); $c->bind($tag, '<ButtonRelease-1>' => ""); $c->bind($tag, '<B1-Motion>' => ""); } sub remove { my ($self) = shift; my ($c) = $self->{'-canvas'}; $c->delete($self->{'-tag'}); delete $self->{'-tag'}; $self->{'-state'} = 'removed'; } sub display { my ($self,%args) = @_; my ($c) = $self->{'-canvas'}; my ($tag); my ($x) = $self->{'-x'}; my ($y) = $self->{'-y'}; if (defined( $args{'-x'} )) { $self->{'-x'} = $x = $args{'-x'}; } if (defined( $args{'-y'} )) { $self->{'-y'} = $y = $args{'-y'}; } if ($self->{'-state'} eq 'open') { $tag = $c->create('image',$x,$y,-image=>$self->{'-image'},-anchor=>'nw'); } else { $tag = $c->create('rectangle',$x,$y,$x+$cx,$y+$cy,-fill=>"blue"); $self->{'-state'} = 'hide'; } $self->{'-tag'} = $tag; if ($args{'-movable'}) { $self->movable(); } $self; } sub hide { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($tag) = $self->{'-tag'}; my ($tags) = $c->itemcget($tag,'-tag'); my ($x,$y) = $c->coords($tag); my (@seq) = $c->bind($tag); my (@bind) = (); # Representation chaned. but tag and event have to be repserved. foreach (@seq) { push(@bind,$c->bind($tag,$_)); } $c->delete($tag); $self->{'-tag'} = $tag = $c->create('rectangle',$x,$y,$x+$cx,$y+$cy,-fill=>"blue",-tag=>$tag); $c->itemconfigure($tag,-tag=>$tags); while (@seq) { $c->bind($tag,shift(@seq),shift(@bind)); } if (defined($self->{'-board'})) { $self->{'-board'}->log_move( CardPlay::CardUndo->new(-card=>$self,-mode=>'hide')); } $self->{'-state'} = 'hide'; } sub open { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($tag) = $self->{'-tag'}; my ($tags) = $c->itemcget($tag,'-tag'); my ($x,$y) = $c->coords($tag); my (@seq) = $c->bind($tag); my (@bind) = (); foreach (@seq) { push(@bind,$c->bind($tag,$_)); } $c->delete($tag); $self->{'-tag'} = $tag = $c->create('image',$x,$y,-image=>$self->{'-image'},-anchor=>'nw',-tag=>$tag); $c->itemconfigure($tag,-tag=>$tags); while (@seq) { $c->bind($tag,shift(@seq),shift(@bind)); } if (defined($self->{'-board'})) { $self->{'-board'}->log_move( CardPlay::CardUndo->new(-card=>$self,-mode=>'open')); } $self->{'-state'} = 'open'; } sub coords { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($x,$y) = $c->coords($self->{'-tag'}); return ($x,$y); } sub raise { my ($self) = shift; my ($c) = $self->{'-canvas'}; my ($tag) = $self->{'-tag'}; $c->raise($tag); } # use subs qw(plot_down plot_move); $point{'lastX'} = 0; $point{'lastY'} = 0; sub current_card { my ($self) = @_; return $self->{'-canvas'}->gettags('current'); } sub plot_down { my ($self) = shift; my ($w) = @_; my ($e) = $w->XEvent; my ($x, $y) = ($e->x, $e->y); my ($tag) = $self->{'-tag'}; $w->dtag('selected'); $w->addtag('selected', withtag => $self->{'-tag'}); $w->raise($tag); $point{'lastX'} = $x; $point{'lastY'} = $y; } # end plot_down sub plot_move { my ($self) = shift; my ($w) = @_; my $e = $w->XEvent; my ($x, $y) = ($e->x, $e->y); $w->move('selected', $x-$point{'lastX'}, $y-$point{'lastY'}); $point{'lastX'} = $x; $point{'lastY'} = $y; } # end plot_move sub bbox { my ($self) = shift; return $self->{'-canvas'}->bbox($self->{'-tag'}); } sub clear { my ($self) = shift; my ($c) = $self->{'-canvas'}; if (defined($self->{'-tag'})) { $c->delete($self->{'-tag'}); delete $self->{'-tag'}; } # $self->{'-state'} = 'hide'; } 1; # end