bitmap2md r57shell version

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use Image::Magick;
use POSIX qw(ceil);
use Algorithm::Cluster qw/kcluster/;

my %options = (
  resize        => '',
  dither        => 0,
  tiles         => 0,
  colors        => 60,
);

my $quantum = Image::Magick->QuantumDepth;

#################################################
# Options parsing
#################################################
exit(1) unless GetOptions(
  'resize:s'            => \$options{resize},
  'dither=i'            => \$options{dither},
  'colors=i'            => \$options{colors},
  'tiles=i'             => \$options{tiles},
  'sample=s'            => \$options{sample},
  'output=s'            => \$options{output},
  'help'                => \$options{help},
);

if ($options{help}) {
  print <<EOF;
Usage: $0 <options> input_file.(png|jpg|gif|bmp)
Options:
  --resize WxH    : resize the input image to WxH pixels (W and H must be multiples of 8)
  --dither type   : use dithering (0: None, 1: Riemersma, 2: Floyd-Steinberg)
  --tiles type    : tiles 0:local dithering 1:global dithering
  --colors N      : number of colors in the output image (default to 60)
  --sample file   : write a sample image to file
  --help          : prints this message
EOF
  exit(0);
}

my $filename = $ARGV[0];


#################################################
# Options checking
#################################################
die("No filename given") unless defined $filename;

die("Number of colors (-colors) must be between 1 and 60")
  unless ($options{colors} > 0 and $options{colors} < 61);


#################################################
# Reads a file from disk and use it to create an ImageMagick object.
sub open_image {
  my $file = shift;
  my $image = Image::Magick->new;
  open(IMG, $file) or die "Can't open $file : $!";
  close(IMG);
  $image->Read($file);
  return $image;
}


#################################################
# Resize an ImageMagick image.
sub resize {
  my $image = shift;
  my %parameters = @_;
  my $ret = $image->Resize(%parameters);
  die $ret if $ret;
}


#################################################
# Breaks an ImageMagick image into an array of 8x8 ImageMagick images.
sub image_to_tiles {
  my $image = shift;

  my $width  = $image->Get('width');
  my $height = $image->Get('height');

  my $nb_tiles_x = $width / 8;
  my $nb_tiles_y = $height / 8;

  my @tiles;
  my $count = 0;
  for my $y (0 .. $nb_tiles_y - 1) {
    for my $x (0 .. $nb_tiles_x - 1) {
      my $x_offset = $x*8;
      my $y_offset = $y*8;
      my $copy = $image->Clone();
      $copy->Crop("8x8+$x_offset+$y_offset");
      push @tiles, $copy;
    }
  }

  return \@tiles;
}


#################################################
# Computes a 3-dimensional vector from the histogram of a tile.
sub tile_to_vector {
  my $image = shift;

  my @vec = (0, 0, 0);
  my @hist = $image->Histogram();
  while (my @rgboc = splice(@hist, 0, 5)) {
    for my $i (1 .. $rgboc[4]) {
      $vec[0] += $rgboc[0];
      $vec[1] += $rgboc[1];
      $vec[2] += $rgboc[2];
    }
  }

  return @vec;
}


#################################################
# Partition a set of tiles into k clusters. k is the number of palettes needed to
# hold the desired number of colors. The tiles are sorted according to the k-means
# algorithm.
sub tiles_into_clusters {
  my $tiles       = shift;
  my $nb_clusters = shift;

  my (@orfdata, @mask, @weight);

  @weight = (1, 1, 1);

  my $ind = 0;
  for my $tile (@{ $tiles }) {
    my @vec = tile_to_vector($tile);
    push @orfdata, \@vec;
    $mask[$ind] = [ 1, 1, 1 ];
    $ind++;
  }

  my ($clusters, $error, $found) = kcluster(
    nclusters => $nb_clusters,
    transpose => 0,
    npass     => 100,
    method    => 'a',
    dist      => 'e',
    data      => \@orfdata,
    mask      => \@mask,
    weight    => \@weight,
  );

  return $clusters;
}


#################################################
# Build an ImageMagick image with 512 colors (similar to the palette of the MegaDrive).
sub build_512_colors_image {
  my $image = Image::Magick->new;
  $image->Set(size => '512x1');
  $image->ReadImage('canvas:white');

  my @t = (0, 49, 87, 119, 146, 174, 206, 255);

  my $x = 0;
  for my $r (@t) {
    for my $g (@t) {
      for my $b (@t) {
        $image->SetPixel(x => $x++, y => 0, color => [ $r/255, $g/255, $b/255 ]); # normalized colors
      }
    }
  }

  return $image;
}


#################################################
# Converts an RGB value to two bytes (MD format).
sub rgb_to_md_color {
  my $r = shift;
  my $g = shift;
  my $b = shift;

  my $sb = $quantum - 3;
  my $bin = sprintf(
    '0000%03b0%03b0%03b0',
    $b >> $sb,
    $g >> $sb,
    $r >> $sb,
  );

  my $hex = sprintf('%04X', oct("0b$bin"));
  return $hex;
}


#################################################
# Return the index of a color in a palette, or add the color to the palette
# if it hasn't been added yet.
sub add_color_to_palette {
  my $palette = shift;
  my $color   = shift;

  return $palette->{colors}->{$color} if defined $palette->{colors}->{$color};

  $palette->{colors}->{$color} = ++$palette->{maxindex};
}


#################################################
sub tiles_to_asm {
  my $tiles       = shift;
  my $clusters    = shift;
  my $nb_clusters = shift;

  open(OUTPUT, '>', $options{output}) or die "Can't open $options{output} for writing : $!";

  my @palettes;
  my %color_indexes;

  # Do not add the transparent color (index 0) here, so there is no conflict with the black color.
  for my $num (0 .. $nb_clusters-1) {
    $palettes[$num]->{colors} = {};
    $palettes[$num]->{maxindex} = 0;
  }

  for my $ind (0 .. $#$tiles) {
    my $t = $tiles->[$ind];
    my $palette_num = $clusters->[$ind];
    my @pixels = $t->GetPixels(map => 'RGB', width => 8, height => 8);
    print OUTPUT "| Tile #$ind ; palette #$palette_num\n";
    while (my @l = splice(@pixels, 0, 8*3)) {
      print OUTPUT ".long 0x";
      while (my @p = splice(@l, 0, 3)) {
        my $color = rgb_to_md_color($p[0], $p[1], $p[2]);
        my $color_index = sprintf('%X', add_color_to_palette($palettes[$palette_num], $color));
        print OUTPUT $color_index;
      }
      print OUTPUT "\n";
    }
    print OUTPUT "\n";
  }

  for my $p (@palettes) {
    if (keys(%{ $p->{colors} }) > 15) {
      die "Bug : a palette contains more than 15 colors, this shouldn't happen.";
    }
  }

  for my $ind (0 .. $#palettes) {
    my $p = $palettes[$ind];
    print OUTPUT "| Palette #$ind\n";
    print OUTPUT ".word 0x0000\n";
    for my $color (sort { $p->{colors}->{$a} <=> $p->{colors}->{$b} } keys %{ $p->{colors} }) {
      print OUTPUT ".word 0x$color\n";
    }
    for my $i ($p->{maxindex}+1 .. 15) {
      print OUTPUT ".word 0x0000 | unused\n";
    }
    print OUTPUT "\n";
  }

  close OUTPUT;
}



#################################################
#                Main script                    #
#################################################
$|++; # unbuffered stdout
my $image = open_image($filename);
my $colorsimage = build_512_colors_image();

if ($options{resize}) {
  resize($image, geometry => $options{resize}, filter => 'Lanczos');
}

my $width  = $image->Get('width');
my $height = $image->Get('height');

if ($width % 8 or $height % 8) {
  die "The width and height of the image must be a multiple of 8";
}

my $nb_tiles_x = $width / 8;
my $nb_tiles_y = $height / 8;
my $nb_tiles = $nb_tiles_x * $nb_tiles_y;
print "Ouput : ${width}x$height pixels, ${nb_tiles_x}x$nb_tiles_y tiles.\n";

my $nb_clusters = ceil($options{colors} / 15);

print "Sorting tiles... ";
my $tiles_ref = image_to_tiles($image);
my $clusters = tiles_into_clusters($tiles_ref, $nb_clusters);
print "done.\n";

my @montages;
for my $i (1 .. $nb_clusters) {
  push @montages, Image::Magick->new;
}

my @tid;
for my $ind (0 .. $#$tiles_ref) {
  my $num = $clusters->[$ind];
  my $im = $montages[$num];
  push @$im, $tiles_ref->[$ind];
  push @tid, $#$im;
}

$options{ditherm} = "Riemersma";
$options{ditherm} = "Floyd-Steinberg" if ($options{dither} == 2);

print "Global quantization... ";
my @dimage;
my @montages_flat;
for my $i (0 .. $#montages) {
  $montages_flat[$i] = $montages[$i]->Montage(geometry => '8x8', tile => '1x');
  $montages_flat[$i]->Quantize(colors => 15, dither => $options{dither}, "dither-method" => $options{ditherm});
  $montages_flat[$i]->Remap(image => $colorsimage, dither => 0);

  $dimage[$i] = $image->Clone();
  $dimage[$i]->Remap(image => $montages_flat[$i], dither => $options{dither}, "dither-method" => $options{ditherm});
}

print " done.\n";

print "Remapping palette of each tile :\n";
my @stars = ('*') x 51;
print "0%                                             100%\n";
for my $y (0 .. $nb_tiles_y - 1) {
  for my $x (0 .. $nb_tiles_x - 1) {
    my $ind = $y*$nb_tiles_x+$x;
    my $num = $clusters->[$ind];
    my $im =  $dimage[$num];
    my $x_offset = $x*8;
    my $y_offset = $y*8;
    if ($options{tiles} == 0) { #local
      $im = $montages_flat[$num];
      $x_offset = 0;
      $y_offset = $tid[$ind]*8;
    }
    my $copy = $im->Clone();
    $copy->Crop("8x8+$x_offset+$y_offset");
    $tiles_ref->[$ind] = $copy;
    print shift(@stars) unless (!@stars or $ind % int($nb_tiles/50));
  }
}
map { print $_ } @stars;
print "\n";

if ($options{sample}) {
  my $final_image = Image::Magick->new;
  for my $tile (@{ $tiles_ref }) {
    push @$final_image, $tile;
  }
  my $q = $final_image->Montage(geometry => '8x8', tile => "${nb_tiles_x}x$nb_tiles_y");
  $q->Write($options{sample});
  print "Sample image written to $options{sample}\n";
}

if ($options{output}) {
  tiles_to_asm($tiles_ref, $clusters, $nb_clusters);
  print "ASM code written to $options{output}\n";
}