# ColorChooser: A Tk color chooser widget.
#
# Email comments, questions or bug reports to Martin Herrmann, <Martin-Herrmann@gmx.de>

# RCS version $Revision: 1.2 $


package Tk::ColorChooser;
use vars qw($VERSION);
$VERSION = '$Revision: 1.2 $';

use strict;
use warnings;
use vars qw(@EXPORT_OK);
use base qw(Tk::Derived Tk::Toplevel);
use Tk::widgets qw(Frame Button Label Pane);
use Color::Rgb;
use Tk::Balloon;

Construct Tk::Widget 'ColorChooser';

# Class initializer.

sub ClassInit {

    # ClassInit is called once per MainWindow, and serves to
    # perform tasks for the class as a whole.  Here we create
    # objects used by all instances of the class.

    my ($class, $mw) = @_;

	my $cbut = pack("b8" x 8,
					".......",
					".......",
					".......",
					".......",
					".......",
					".......",
					".......",
					".......");

	$mw->DefineBitmap('cbut' => 8, 8, $cbut);

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

sub Populate {

  my($self, $args) = @_;

  # set options
  for (qw(Scale Scrollbar)) {
	$self->optionAdd("*$_.width", "10", "userDefault");
  }
  my $rgb        = new Color::Rgb(rgb_txt=>'/usr/openwin/lib/X11/rgb.txt');
  my $width      = 300;
     $width      = delete $args->{-width} if defined $args->{-width};
  my $height     = 250;
     $height     = delete $args->{-height} if defined $args->{-height};
  my $sort       = delete $args->{-sort};
  my $colorsRef  = delete $args->{-colors};
  my $userrows   = delete $args->{-rows};
  my $balloon    = $self->Balloon(-bg => "khaki2", -initwait => 700);

  $self->SUPER::Populate($args);
  $self->withdraw;

  #$self->title($title);
  $self->geometry($width."x".$height."+50+50");
  my $infoF = $self->Frame()->pack(
							  -fill    => 'x',
							  -padx    => 2,
							  -pady    => 3,
							 );
  my $scaleF = $self->Frame->pack(
							 -fill    => 'x',
							);
  my $colorF = $self->Scrolled("Pane",
						  -scrollbars => "osoe",
						 )->pack(
								 -fill    => 'both',
								 -expand  => 1,
								);
  my $buttonF = $self->Frame->pack(
								-fill    => 'x',
								-ipady   => 6,
							   );
  my $color = "";
  my $hex   = "";
  my $rgbs  = "";

  my $hexL = $infoF->Label(-textvariable => \$hex,   -relief => 'groove', -bd => 2)->pack(-side => "left");
  $balloon->attach($hexL, -msg => "this is the hex value of the color (#RRGGBB)");

  my $rgbL = $infoF->Label(-textvariable => \$rgbs,  -relief => 'groove', -bd => 2)->pack(-side => "left");
  $balloon->attach($rgbL, -msg => "this is the decimal value of the color (R,G,B)");

  my $nameL = $infoF->Label(-textvariable => \$color, -relief => 'groove', -bd => 2)->pack(-side => "left");
  $balloon->attach($nameL, -msg => "this is the name of the color (if available)");

  my $colL =
	$infoF->Label(-text => "         ",   -relief => 'groove', -bd => 2)->pack(-side => "left", 
																			 -expand => 1, -fill => "x");
  $balloon->attach($colL, -msg => "this is the color");

  my $colR = 1;
  my $colG = 1;
  my $colB = 1;

  my $rS = $scaleF->Scale(-variable => \$colR,
			   -from => 0,
			   -to => 255,
			   -resolution => 1,
			   -orient => 'horizontal',
			   -width => 10,
			   -showvalue => 0,
			   -command => sub {
				 $color = "";
				 $hex   = $rgb->rgb2hex($colR, $colG, $colB, "#");
				 $rgbs  = $rgb->hex2rgb($hex,",");
				 $colL->configure(-background => $hex);
			   })->pack(-anchor => "w", -fill => "x");
  $balloon->attach($rS, -msg => "adjusts the red value");

  my $gS = $scaleF->Scale(-variable => \$colG,
			   -from => 0,
			   -to => 255,
			   -resolution => 1,
			   -orient => 'horizontal',
			   -width => 10,
			   -showvalue => 0,
			   -command => sub {
				 $color = "";
				 $hex   = $rgb->rgb2hex($colR, $colG, $colB, "#");
				 $rgbs  = $rgb->hex2rgb($hex,",");
				 $colL->configure(-background => $hex);
			   })->pack(-anchor => "w", -fill => "x");
  $balloon->attach($gS, -msg => "adjusts the green value");

  my $bS = $scaleF->Scale(-variable => \$colB,
			   -from => 0,
			   -to => 255,
			   -orient => 'horizontal',
			   -width => 10,
			   -showvalue => 0,
			   -command => sub {
				 $color = "";
				 $hex   = $rgb->rgb2hex($colR, $colG, $colB, "#");
				 $rgbs  = $rgb->hex2rgb($hex,",");
				 $colL->configure(-background => $hex);
			   })->pack(-anchor => "w", -fill => "x");
  $balloon->attach($bS, -msg => "adjusts the blue value");

  $buttonF->Button(
				   -width   => 7,
				   -text    => 'OK',
				   -command => sub {
					if ($color ne "") {
					  $self->{color} = $color
					}
					else {
					  $self->{color} = $hex
					}
				  },
				 )->pack(-fill => "x",
						 -side    => 'left',
						 -expand  => 1,
						);
  $buttonF->Button(
				  -width   => 7,
				  -text    => 'Cancel',
				  -command => sub {$self->{color} = undef},
				 )->pack(-fill => "x",
						 -side    => 'left',
						 -expand  => 1,
						);

  my @colors;
  if (ref($colorsRef) eq "ARRAY") {
	@colors = @$colorsRef;
  }
  else {
	@colors = $rgb->names;
  }
  my $i = 0;
  my ($frame, @rgbs, $rows);

  if (defined $userrows and $userrows > 0 and $userrows < $#colors+1) {
	$rows = $userrows;
  }
  else {
	$rows = calcLayout($#colors+1);
  }

  if (defined $sort and $sort) { @colors = sort @colors; }

  foreach (@colors) {
	$i++;
	if ($i == 1 or $i % $rows == 1 or $rows == 1) { # a frame for the first and every $rows button (modulo)
	  $frame = $colorF->Frame()->pack(-side => "left", -anchor => "n");
	}
	my $but;
	$but =
	  $frame->Button(-bitmap => "cbut",
					 -padx       => 0,
					 -pady       => 0,
					 -relief     => "groove",
					 -background => $_,
					 -command    => sub {
					   my $col = $but->cget(-bg);
					   $colL->configure(-background => $col);
					   if ($col =~ m/^#/) {
						 $color = "";
						 $hex   = $col;
						 $rgbs  = $rgb->hex2rgb($hex,",");
						 @rgbs  = $rgb->hex2rgb($hex);
					   }
					   else {
						 $color = $col;
						 $hex   = $rgb->hex(lc($color),"#");
						 $rgbs  = $rgb->rgb(lc($color),",");
						 @rgbs  = $rgb->rgb(lc($color));
					   }
					   $colR = $rgbs[0];
					   $colG = $rgbs[1];
					   $colB = $rgbs[2];
					 }
					)->pack(-padx => 0, -pady => 0);
	$balloon->attach($but, -msg => $_);
  }
}


sub Show {
  my($self, $grab) = @_;
  my $old_focus = $self->focusSave;
  $self->Popup();
  $self->_wait;
  return($self->{color});
}

sub _wait {
  my($self) = @_;
  $self->waitVariable(\$self->{color});
  $self->withdraw;
  $self->Callback(-command => $self->{color});
}

sub calcLayout {

  my $elements = shift;
  my $columns;
  my $rows;

  if ($elements > 0) {
	$columns = sqrt($elements - 1);
	$columns = int($columns) + 1;
	die "calcLayout: No columns!" if ($columns <= 0);
	$rows    = int($elements / $columns);
	while ($columns * $rows < $elements) { $rows++; }
  }
  else {
	$rows    = 0;
	$columns = 0;
  }
  return $rows;
}

1;

# Tell Emacs that this is really a perl script
# Local Variables:
# mode:perl
# End: