#!/usr/bin/perl
use warnings;
use strict;
use Tk;

#start Tk 
my $mw = MainWindow->new(-background => 'black');
$mw->geometry( '600x570+20+20' );

#setup CollapsablePlayer frame class based on Lidie's CollapsableFrame
+ 
######################################################################
+###### 
{
package CollapsablePlayer;

use Tk::widgets qw/Frame/;
use vars qw/$cf_height_bias $im_Close $im_Open/;
use strict;

use base qw/Tk::Frame/;
Construct Tk::Widget 'CollapsablePlayer';

sub ClassInit {
    # Define global variables and images for the class. 
    my($class, $mw) = @_;

   $cf_height_bias = 22;

    $im_Close = $mw->Bitmap(-data => <<'END');
#define close_width 16 
#define close_height 16 
static unsigned char close_bits[] = {
  0x00, 0x80, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0x
+c0,
  0xf0, 0xc7, 0xe0, 0xc3, 0xc0, 0xc1, 0x80, 0xc0, 0x00, 0xc0, 0x00, 0x
+c0,
  0x00, 0xc0, 0x00, 0xc0, 0xfe, 0xff, 0xff, 0xff, };
END

    $im_Open = $mw->Bitmap(-data => << 'END');
#define open_width 16 
#define open_height 16 
static unsigned char open_bits[] = {
  0x00, 0x80, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x40, 0xc0, 0xc0, 0x
+c0,
  0xc0, 0xc1, 0xc0, 0xc3, 0xc0, 0xc1, 0xc0, 0xc0, 0x40, 0xc0, 0x00, 0x
+c0,
  0x00, 0xc0, 0x00, 0xc0, 0xfe, 0xff, 0xff, 0xff, };
END

    $class->SUPER::ClassInit($mw);

} # end ClassInit 

sub Populate {
    my($self, $args) = @_;

    my $height = $args->{-height};
    $self->SUPER::Populate($args);

    $self->{frame} = $self->Frame(
       qw/-borderwidth 1 -height 16 -relief ridge -background LightSky
+Blue3 /,
#      qw/-borderwidth 1 -height 16 -relief ridge  /,   #original 
       );
    $self->{frame}->pack(
        qw/-anchor center -expand 1 -fill x -pady 1 -side left/,
       );

    $self->{opcl} = $self->Label(
        qw/-borderwidth 0 -relief raised  -text $height -background gr
+een/
#       qw/-borderwidth 0 -relief raised  -text $height /  #original  
        );

    $self->{opcl}->bind('<Button-1>' => [sub {$_[1]->toggle}, $self]);
    $self->{opcl}->place(
        qw/-x 5 -y -1 -width 21 -height 21 -anchor nw -bordermode igno
+re/);

    $self->{ident} = $self->Label(qw/-anchor w -borderwidth 1 -backgro
+und lightyellow/);
    $self->{ident}->place(
        qw/-x 23 -y 3  -height 12 -anchor nw -bordermode ignore/);

    $self->{colf} = $self->{frame}->Frame();
    $self->{colf}->place(qw/-x 20 -y 15 -relwidth 1.0 -width -20/);
    $self->Advertise('colf' => $self->{colf});

    if (not defined $args->{-width}) {
        $args->{-width} = $self->parent->cget(-width);
    }

    $self->ConfigSpecs(
      -background  => [['SELF', 'CHILDREN'], qw/ background Background
+ /],
      -height      => [qw/METHOD height Height 47/],
      -image       => [$self->{opcl}, 'image', 'Image', $im_Open],
      -title       => '-text',
      -text        => [$self->{ident}, qw/text Text NoTitle/],
      -width       => [$self->{frame}, qw/width Width 500/],
    );

} # end Populate 

sub bias {return $cf_height_bias}

# Public instance methods. 
sub close {
    my($self) = @_;
    $self->{opcl}->configure(-image  => $im_Open);
    $self->{frame}->configure(-height => 16);
}

sub open  {
    my($self) = @_;
    $self->{opcl}->configure(-image  => $im_Close);
    $self->{frame}->configure(-height => $self->{opcl}->cget(-text));
}

sub state {
    my($self) = @_;
    my $i = $self->{opcl}->cget(-image);
    my $op = ($i == $im_Open) ? 'close' : 'open';
    return $op;
}

sub toggle {
    my($self) = @_;
    my $i = $self->{opcl}->cget(-image);
    my $op = ($i == $im_Open) ? 'open' : 'close';
    $self->$op();
}

# Private instance methods. 

sub height {
    my($self, $h) = @_;
    $self->{opcl}->configure(-text => $h);
}

1;
} #end of package 
################################################################### 

my %tframe;

for my $player ('Player1',,'Player2', 'Player3','Player4'){
 $tframe{$player}{'frameC'} = $mw->CollapsablePlayer(
                    -height => 130,
                    -title => $player,
                    -borderwidth => 0,
                    -width=> 800,
#                   -background =>'Lightsteelblue3', 
                 )->pack(-side =>'top', -fill =>'x', -anchor =>'n');

  $tframe{$player}{'frame'} = $tframe{$player}{'frameC'}->Subwidget('c
+olf');
  $tframe{$player}{'frame'}->configure(-borderwidth => 0);
  $tframe{$player}{'frameC'}->open;

      #make seat 
  my $currframe = $tframe{$player}{'frame'}; # whole width of seat and
+ table 
  $tframe{$player}{0} = $currframe->Frame(-borderwidth => 0,-backgroun
+d =>'grey45')
             ->pack(-side =>'left', -pady =>0 , -anchor=>'w',-fill => 
+'both');

  $tframe{$player}{'label'} = $currframe->Label(-text => $player ,
                         -background =>'white',
                         -height => 5)
                         ->pack( -fill=>'both', -expand => 1 )
}


MainLoop;
[download]