package Imager::File::XPM;
use strict;
use Imager;
use vars qw($VERSION);
$VERSION = '0.001';

Imager->register_writer
  (
   type => 'xpm',
   single => \&_write,
  );

Imager->register_reader
  (
   type => 'xpm',
   single => \&_read,
  );

# characters we can use to represent a color index
my @color_chars =
  (
   ' ', '.',
   'x', 'X', 'o', 'O', '+', '@', '#', '$', '%', '&', '*', '=', '-', 
   ';', ';', '>', ',', '<',
   '0' ... '9',
   'a' ... 'n', 'p' ... 'w', 'y', 'z',
   'A' ... 'N', 'P' ... 'W', 'Y', 'Z',
   '!', '~', '^', '/', '(', ')', '_', '`', "'", ']', '[',
   '{', '}', '|',
  );

sub _write {
  my ($im, $io, %hsh) = @_;

  my $name = $hsh{name} || $im->tags(name => "xpm_name") || 'noname';

  unless ($name =~ /^[A-Za-z_][a-zA-Z_0-9]*$/) {
    $im->_set_error("xpm_name must be a valid X identifier");
    return;
  }
  $io->write("/* XPM */\x0A");
  $io->write("static char *${name}[] = {\x0A");

  # build an index of the colors used
  my %colors;
  my $have_transp = 0;
  _build_color_index($im, \%colors, \$have_transp);

  my $num_colors = $have_transp + keys %colors;
  my @color_names = _make_color_names($num_colors);
  my $num_chars = length $color_names[0];
  my $transp_name;
  $transp_name = shift @color_names if $have_transp;
  @colors{sort keys %colors} = @color_names;
  my %name_to_color = reverse %colors;
  $io->write("/* width height ncolors chars_per_pixel */\x0A");
  $io->write('"' . $im->getwidth . ' ' . $im->getheight . 
	     " $num_colors $num_chars\",\x0A");
  $io->write(qq!"$transp_name c none",\x0A!) if $have_transp;
  for my $name (@color_names) {
    $io->write("\"$name c #" . unpack("H*", $name_to_color{$name}) .
	       "\",\x0A");
  }
  
  # write the image lines
  my @channels = ( 0 .. $im->getchannels - 1 );
  if (@channels < 3) {
    unshift @channels, ( 0, 0 ); # grey to rgb
  }
  pop @channels if @channels == 4;
  $io->write("/* pixels */\x0A");
  if ($have_transp) {
    for my $y (0 .. $im->getheight - 1 ) {
      my $samples = $im->getsamples('y' => $y, channels => \@channels);
      my @alpha_samples = $im->getsamples('y' => $y, channels => [ 3 ]);
      my $line = '"';
      for my $x ( 0 .. $im->getwidth - 1) {
	if ($alpha_samples[$x] < 0x80) {
	  $line .= $transp_name;
	}
	else {
	  $line .= $colors{substr $samples, $x * 3, 3};
	}
      }
      $line .= '"';
      $line .= "," unless $y == $im->getheight - 1;
      $line .= "\x0A";
      $io->write($line);
    }
  }
  else {
    for my $y (0 .. $im->getheight - 1 ) {
      my $samples = $im->getsamples('y' => $y, channels => \@channels);
      my $line = '"';
      for my $x ( 0 .. $im->getwidth - 1) {
	$line .= $colors{substr $samples, $x * 3, 3};
      }
      $line .= '"';
      $line .= "," unless $y == $im->getheight - 1;
      $line .= "\x0A";
      $io->write($line);
    }
  }
  $io->write("};\x0A");

  return 1;
}

sub _read {
  my ($im, $io, %hsh) = @_;

  $io->_set_error("XPM reading unimplemented");

  return;
}

sub _build_color_index {
  my ($im, $colors, $have_transp) = @_;

  my @channels = ( 0 .. $im->getchannels - 1 );
  if (@channels < 3) {
    unshift @channels, ( 0, 0 ); # grey to rgb
  }
  my %colors;
  if (@channels == 4) {
    pop @channels;
    for my $y ( 0 .. $im->getheight - 1) {
      my $base = 0;
      my $samples = $im->getsamples('y' => $y, channels => \@channels);
      my @alpha_samples = $im->getsamples('y' => $y, channels => [ 3 ]);
      for my $x ( 0 .. $im->getwidth - 1 ) {
	if ($alpha_samples[$x] < 0x80) {
	  $$have_transp = 1;
	}
	else {
	  $colors->{substr $samples, $x*3, 3} = 1;
	}
      }
    }
  }
  else {
    for my $y ( 0 .. $im->getheight - 1) {
      my $samples = $im->getsamples('y' => $y, channels => \@channels);
      for my $x ( 0 .. $im->getwidth - 1 ) {
	$colors->{substr $samples, $x*3, 3} = 1;
      }
    }
  }
}

sub _make_color_names {
  my $num_colors = shift;

  my @names;
  for my $index (0 .. $num_colors - 1) {
    my $num = $index;
    my $name = $color_chars[$num % @color_chars];
    $num  = int($num / @color_chars);
    while ($num) {
      $name = $color_chars[$num % @color_chars] . $name;
      $num = int($num / @color_chars);
    }
    push @names, $name;
  }
  my $num_chars = length $names[-1];
  for my $name (@names) {
    $name = " " x ($num_chars - length $name) . $name
      if length $name < $num_chars;
  }

  return @names;
}

1;