Karoshi MSX Community

use strict;
use warnings;
use Image::Magick;
use List::MoreUtils qw/ uniq /;

sub bin2dec {
return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
}

sub extract_pattern {
my ($row) = @_;
 
my @colors = sort {$a<=>$b} grep {$_} uniq @{$row};
my $color_a = shift @colors;
my $color_b = shift @colors;
my $color_c = shift @colors;

die "Too many colors." if $#colors >= 0;

if(defined $color_c) {
if(($color_b | $color_c) == $color_a) {
($color_a, $color_c) = ($color_c, $color_a);
} elsif(($color_a | $color_c) == $color_b) {
($color_b, $color_c) = ($color_c, $color_b);
} elsif(($color_a | $color_b) != $color_c) {
die "Wrong row colors.";
}
}

my @layers = ();
my $cc = defined $color_c ? 64 : 0;

my @bits0 = map {defined $color_a && $_ == $color_a || defined $color_c && $_ == $color_c ? 1 : 0} @{$row};
push @layers, [\@bits0, $color_a];

if (defined $color_b) {
my @bits1 = map {$_ == $color_b || defined $color_c && $_ == $color_c ? 1 : 0} @{$row};
push @layers, [\@bits1, ($color_b | $cc)];
}

return \@layers;
}

sub export_sprite {
my ($image, $tx, $ty) = @_;

my @sprite0 = ();
my @sprite1 = ();

foreach my $y (0..15) {
my $oy = $ty + $y;

my @row = ();
foreach my $x (0..15) {
my $ox = $tx + $x;
$row[$x] = $image->[0]->Get("Index[$ox,$oy]");
}

my $layers = extract_pattern \@row;
$sprite0[$y] = $layers->[0];
$sprite1[$y] = $layers->[1] if $layers->[1];
}

my @sprites = (\@sprite0, \@sprite1);
return \@sprites;
}

sub print_sprite_patterns {
my ($sprite, $file) = @_;

foreach my $column (0..1) {
foreach my $y (0..15) {
my $row = $sprite->[$y]->[0];
my $bits = '';
$bits .= $row->[$column * 8 + $_]||0 for(0..7);
my $byte = bin2dec($bits);
print $file "db $byte\t; B:$bits R:$y\n";
}
}
}

sub print_sprite_colors {
my ($sprite, $file) = @_;

foreach my $y (0..15) {
my $byte = $sprite->[$y]->[1] || 0;
my $color = $byte & 15;
my $cc = $byte & 64 ? 1 : 0;
print $file "db $byte\t; C:$color CC:$cc R:$y\n";
}
}

sub export_sprites {
my ($filename, $out_pattern, $out_color) = @_;

# read image
my $image = Image::Magick->new;
$image->Read($filename);

# image size
my $width = $image->Get("width");
my $height = $image->Get("height");

if($width % 16 || $height % 16) {
die "Wrong image size: $width x $height. Must be multiple of 16x16.\n";
}

open OUTPAT, ">$out_pattern" or die "Cannot create $out_pattern file.";
open OUTCOL, ">$out_color" or die "Cannot create $out_color file.";

# export sprites
my $sprites_qty = ($width / 16) * $height / 16;
my $x = 0;
my $y = 0;
for(my $i = 1; $i <= $sprites_qty; $i++) {
# extract sprite layers
my $sprites = export_sprite $image, $x, $y;

# write sprite
print OUTPAT "\t; sprite $i at ($x, $y) ------------\n";
print OUTCOL "\t; sprite $i at ($x, $y) ------------\n";
for my $layer_no (0..scalar @$sprites - 1) {
print OUTPAT "\t; layer $layer_no\n";
print_sprite_patterns $sprites->[$layer_no], *OUTPAT;

print OUTCOL "\t; layer $layer_no\n";
print_sprite_colors $sprites->[$layer_no], *OUTCOL;
}

# next sprite
$x += 16;
if($x == $width) {
$x = 0;
$y += 16;
}
}

close OUTPAT;
close OUTCOL;
}

if($#ARGV < 0) {
die "Missing filename.";
}

my $file_pat = $ARGV[1] || (split /\./, $ARGV[0])[0].".pat";
my $file_col = $ARGV[2] || (split /\./, $ARGV[0])[0].".col";
export_sprites $ARGV[0], $file_pat, $file_col;