Image::Embroidery - Parse and display embroidery data files

  use Image::Embroidery;

  # Constructor
  $emb = Image::Embroidery->new();

    use Image::Embroidery qw(:all);

    $emb = Image::Embroidery->new();

    $emb->read_file( '/path/to/embroidery.dst' ) or
       die "Failed to read data file: $!";

    # fiddle with the data structure some. this would make
    # the 201st entry a normal stitch that went 5 units right,
    # and 7 units up
    $emb->{'data'}{'pattern'}[200] = [ $NORMAL, 5, 7 ];

    # supply a new file name, or use the default of 
    # the original file name
    $emb->write_file( '/path/to/new_embroidery.dst' ) or
        die "Failed to write data file: $!";

    use Image::Embroidery;
    use GD;

    $emb = Image::Embroidery->new();

    $emb->read_file( '/path/to/embroidery.dst' ) or
        die "Failed to read data file: $!";

    $im = new GD::Image( $emb->size() );

    # the first color you allocate will be the background color
    $black = $im->colorAllocate(0,0,0);

    # the order in which you allocate the rest is irrelevant
    $gray = $im->colorAllocate(128,128,128);
    $red = $im->colorAllocate(255,0,0);

    # you can control the thickness of the lines that are used to draw the 
    # image. the default thickness is 1, which will let you see individual
    # stitches. The higher you set the thickness, the smoother the image will
    # look. A thickness of 3 or 4 is good for showing what the finished product
    # will look like
    $im->setThickness(3);

    # the order you specify the colors is the order in which they
    # will be used. you must specify the correct number of colors
    $emb->draw_logo($im, $gray, $red);

    open(IMG, ">", "/path/to/embroidery.png");
    #  make sure you use binary mode when running on Windows
    binmode(IMG);
    print IMG $im->png;
    close(IMG);

    $emb->read_file( '/path/to/embroidery.exp', 'exp' );
    $emb->save_file( '/path/to/embroidery.dst', 'dst' );

package Image::Embroidery;

use 5.006;
use strict;
use warnings;
use Carp;
use IO::File;
use Bit::Vector;
use Data::Dumper;

use vars qw(
	$VERSION
	@ISA
	@EXPORT_OK
	$NORMAL
	$JUMP
	$COLOR_CHANGE
);

require Exporter;

@ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw($NORMAL $JUMP $COLOR_CHANGE) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

$VERSION = '1.2';

$NORMAL = 0;
$JUMP = 1;
$COLOR_CHANGE = 2;

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self  = {
		ignore_header_coordinates => 0,
	};

	$self->{'filename'} = undef;

	bless ($self, $class);
	return $self;
}

sub read_file {
	my ($self, $file, $type) = @_;

	unless(defined($file)) { carp("No filename provided"); return 0; }
	unless(-f "$file" and -r "$file") { carp("File $file unreadable or nonexistant"); return 0; }
	my $fh = IO::File->new($file) or carp("Unable to open $file") and return 0;
  
	$self->{'filename'} = $file;
  
	$type = (defined($type)) ? lc($type) : 'tajima';

	if($type eq 'tajima' or $type eq 'dst') {
		return _read_tajima_file($self, $fh);
	} elsif($type eq 'melco' or $type eq 'exp') {
		return _read_melco_file($self, $fh);
	} else {
		carp("Request to read unknown file type!");
	}
}

sub _read_melco_file {
	my ($self, $fh) = @_;
	my $record;
	$self->{'data'} = {};

	my $colorchange = '8001';

	# i don't know why both of these can be used
	# for a jump record.
	my $jump1 = '8002';
	my $jump2 = '8004';

	# initialize pattern info, and set defaults for stuff that melco doesn't use (MX/MY/PD multi-volume data)
	foreach my $field ('color_changes', 'stitches', '+X', '-X', '+Y', '-Y', 'MX', 'MY', 'PD') {
		$self->{'data'}{$field} = 0;
	}
	$self->{'data'}{'label'} = 'FromMelco';

	# current offset from the starting point
	my $currentX = 0;
	my $currentY = 0;

	while($fh->read($record, 2)) {
		$record = unpack('H4', $record);

		my ($x, $y);

		# remove empty records that are sometimes inserted after color
		# changes.
		if($record eq '0000') {
			next;
		} elsif($record eq $colorchange) {
			push(@{$self->{'data'}{'pattern'}}, [ $COLOR_CHANGE ]);
			$self->{'data'}{'color_changes'}++;
			next;
		} elsif($record eq $jump1 or $record eq $jump2) {
			$fh->read($record, 2);
			($x, $y) = _decode_melco_delta( unpack('H4', $record) );
			push(@{$self->{'data'}{'pattern'}}, [ $JUMP, $x, $y ]);
		# some generators insert 8080 records, but I don't know what they mean
		} elsif($record =~ /^80/) {
			$fh->read(undef, 2);
			next;
		} else {
			($x, $y) = _decode_melco_delta($record);

			push(@{$self->{'data'}{'pattern'}}, [ $NORMAL, $x, $y ]);
			$self->{'data'}{'stitches'}++;
		}

		# keep track of how big the pattern is
		$currentX += $x;
		$currentY += $y;
		if($currentX > $self->{'data'}{'+X'}) { $self->{'data'}{'+X'} = $currentX; }
		if($currentX < $self->{'data'}{'-X'}) { $self->{'data'}{'-X'} = $currentX; }
		if($currentY > $self->{'data'}{'+Y'}) { $self->{'data'}{'+Y'} = $currentY; }
		if($currentY < $self->{'data'}{'-Y'}) { $self->{'data'}{'-Y'} = $currentY; }
	}

	# these are magnitudes, so remove the minus sign
	$self->{'data'}{'-X'} = abs($self->{'data'}{'-X'});
	$self->{'data'}{'-Y'} = abs($self->{'data'}{'-Y'});

	# store the total size of the pattern
	$self->{'data'}{'x_size'} = $self->{'data'}{'+X'} + $self->{'data'}{'-X'};
	$self->{'data'}{'y_size'} = $self->{'data'}{'+Y'} + $self->{'data'}{'-Y'};

	# last position
	$self->{'data'}{'AX'} = $currentX;
	$self->{'data'}{'AY'} = $currentY;

	return 1;
}

sub _encode_melco_delta {
	my ($x, $y) = @_;
	if($x < 0) { $x += 256; }
	if($y < 0) { $y += 256; }

	my $delta_record = sprintf('%02x%02x', $x, $y);
	return $delta_record;
}

sub _decode_melco_delta {
	my ($record) = @_;
	my $x = hex(substr($record, 0, 2));
	my $y = hex(substr($record, 2, 2));
	
	# 127 is the max stitch length, 128 is a special value
	# for encoding jumps and color changes
	if($x == 128 or $y == 128) {
		return (0, 0);
	}

	if($x > 127) { $x = $x - 256; }
	if($y > 127) { $y = $y - 256; }

	return ($x, $y);
}

# parse a Tajima DST file
sub _read_tajima_file {
	my ($self, $fh) = @_;

	$self->{'data'} = {};
	my $field;
	my $stitch;

	my @x_incr = (  0,  0, 81,-81,  0,  0,  0,  0,
			3, -3, 27,-27,  0,  0,  0,  0,
			1, -1, 9,  -9,  0,  0,  0,  0
	);
	my @y_incr = (  0,  0,  0,  0,-81, 81,  0,  0,
			0,  0,  0,  0,-27, 27, -3,  3,
			0,  0,  0,  0, -9,  9, -1,  1
	);

	# keep track of the actual color changes we see, to verify that
	# it matches what's in the header. some programs incorrectly put
	# the number of colors in the header, which will be one too large
	my $actual_color_changes = 0;

	# i don't think the order of these header elements
	# can change, but i'll be flexible.
	while($fh->read($field, 2)) {
		# read the next character, which should be a colon
		# that separates the field name from the value. some
		# file generators forget the colon sometimes, so if
		# we don't get a colon back, we assume it's part of the data
		$fh->read(my $separator, 1);
		unless($separator eq ':') {
			$fh->seek(1,-1);
		}

		if($field eq 'LA') {
			$fh->read(my $label, 16);
			($self->{'data'}{'label'} = $label) =~ s/\s*$//;
		} elsif($field eq 'ST') {
			$fh->read($self->{'data'}{'stitches'}, 7);
			$self->{'data'}{'stitches'} = int($self->{'data'}{'stitches'});
		} elsif($field eq 'CO') {
			my $color_changes;
			$fh->read($color_changes, 3);
			$self->{'data'}{'color_changes'} = int($color_changes);
		} elsif($field =~ /^([-+][XY])$/) {
			$fh->read(my $val, 5);
			$self->{'data'}{"$1"} = int($val);
		} elsif($field =~ /^([AM][XY])$/) {
			my $field_name = $1;
			$fh->read(my $val, 6);
			$val =~ s/ //g;
			if($val =~ /^[\+\-]?\s*\d+$/) {
				$self->{'data'}{"$field_name"} = int($val);
			} else {
				$self->{'data'}{"$field_name"} = 0;
			}
		} elsif($field eq 'PD') {
			$fh->read($self->{'data'}{'PD'}, 9);
		} elsif(unpack('H6', $field) eq '2020') {
			last;
		} else {
			carp("Invalid header field: $field"); return 0;
		}

		# eat the CR that follows each field (except the last one, in which
		# case we're eating a 0x20)
		$fh->read(my $junk, 1);
	}

	$self->{'data'}{'x_size'} = $self->{'data'}{'+X'} + $self->{'data'}{'-X'};
	$self->{'data'}{'y_size'} = $self->{'data'}{'+Y'} + $self->{'data'}{'-Y'};

	# skip to the end of the header
	$fh->seek(512, 0);

	# the file spec for Tajima DST indicates that bits 0 and 1 of a
	# stitch should always be '1', but since they don't mean anything,
	# and some file generators don't follow the spec very carefully,
	# we just require them to be consistent throughout the file.
	# we store the values in the first stitch that we find, then 
	# compare subsequent stitches to the first value we saw. 
	my $stitch_bit_0;
	my $stitch_bit_1;


	while($fh->read($stitch, 3)) {
		my $v = Bit::Vector->new(24);
		$v->from_Hex(unpack('H6', $stitch));

		# just check for consistency to detect corrupt files, these bits are meaningless
		if(defined($stitch_bit_0)) {
			unless($v->bit_test(1) == $stitch_bit_1 and $v->bit_test(0) == $stitch_bit_0) {
				carp("Possibly corrupt data file: ", unpack('H6', $stitch));
			}
		} else {
			$stitch_bit_0 = $v->bit_test(0);
			$stitch_bit_1 = $v->bit_test(1);
		}

		# bit 6 is off for jumps and normal stitches
		if(!$v->bit_test(6)) {
			my ($x, $y) = (0, 0);
			# first two bits are not used. 6 and 7 are record type flags
			foreach my $index(2..5, 8..23) {
				$x += $x_incr[$index] if($v->bit_test($index));
				$y += $y_incr[$index] if($v->bit_test($index));
			}

			# bit 7 will be off for normal stitches, on for jumps
			push(@{$self->{'data'}{'pattern'}}, [ $v->bit_test(7), $x, $y ]);

		} elsif(!$v->bit_test(7)) {
			carp("Invalid operation code");
			return 0;
		} else {
			if($v->to_Hex() eq '0000C3') {
				push(@{$self->{'data'}{'pattern'}}, [ $COLOR_CHANGE ]);
				$actual_color_changes++;
			} elsif($v->to_Hex() eq '0000F3') {
				# this is the 'stop' code. sometimes there is trailing data, so
				# stop reading now.
				last;
			} else {
				carp("Invalid operation code");
				return 0;
			}
		}
	}

	# trust the data more than the header
	if($actual_color_changes != $self->{'data'}{'color_changes'}) {
		# TODO some kind of logging ("Tajima file header lists incorrect number of color changes: $self->{'data'}{'color_changes'}, should be $actual_color_changes");
		$self->{'data'}{'color_changes'} = $actual_color_changes;
	}

	return 1;
}

sub write_file {
	my ($self, $file, $type) = @_;

	unless(defined($self->{'data'}{'pattern'})) {
		carp("You do not have a pattern to write");
		return 0;
	}

	unless(defined($file)) {
		if(defined($self->{'filename'})) {
			$file = $self->{'filename'}; 
		} else {
			carp("No filename supplied");
			return 0;
		}
	}
	my $fh = IO::File->new($file, "w") or carp("Unable to write to $file") and return 0;

	# for windows
	binmode($fh);

	if(defined($type)) {
		$type = lc($type);
	} else {
		$type = 'tajima';
	}

	if($type eq 'tajima' or $type eq 'dst') {
		return _write_tajima_file($self, $fh);
	} elsif($type eq 'melco' or $type eq 'exp') {
		return _write_melco_file($self, $fh);
	} else {
		carp("Request to write unknown file type!");
		return 0;
	}
}

# output a Melco EXP file
sub _write_melco_file {
	my ($self, $fh) = @_;

	foreach my $entry (@{$self->{'data'}{'pattern'}}) {
		if($entry->[0] == $NORMAL) {
			print $fh pack('H4', _encode_melco_delta($entry->[1], $entry->[2]));
		} elsif($entry->[0] == $JUMP) {
			print $fh pack('H4', '8004'); # this can be either 8002 or 8004
			print $fh pack('H4', _encode_melco_delta($entry->[1], $entry->[2]));
		} else { # color change
			# i don't think the extra zero records are required, but most generators
			# seem to put them in there.
			print $fh pack('H8', '80010000');
		}
	}
}

# output a Tajima DST file
sub _write_tajima_file {
	my ($self, $fh) = @_;

	# header
	printf $fh "LA:%-16s\r", $self->{'data'}{'label'};
	printf $fh "ST:%07d\r", $self->{'data'}{'stitches'};
	printf $fh "CO:%03d\r", $self->{'data'}{'color_changes'};

	for('+X', '-X', '+Y', '-Y') { printf $fh "$_:%05d\r", $self->{'data'}{$_}; }

	foreach my $key ('AX', 'AY', 'MX', 'MY') {
		if($self->{'data'}{$key} < 0) { printf $fh "$key:-%5s\r", abs($self->{'data'}{$key}); }
		else { printf $fh "$key:+%5s\r", $self->{'data'}{$key}; }
	}

	printf $fh "PD:%9s", $self->{'data'}{'PD'};

	# pad out the rest of the header (512 bytes total)
	printf $fh ' 'x386;

	# data
	foreach my $entry (@{$self->{'data'}{'pattern'}}) {
		if($entry->[0] == $NORMAL or $entry->[0] == $JUMP) {
			print $fh pack('B24', _get_tajima_move_record(@{$entry}));
		} else { # color change
			print $fh pack('H6', '0000C3');
		}
	}

	# this is the 'stop' code
	print $fh pack('H6', '0000F3');

	$fh->close();

	return 1;
}

sub _get_tajima_move_record {
	my ($jump,$x,$y) = @_;
	my ($b0, $b1, $b2);

	my %x = _get_tajima_components($x);
	my %y = _get_tajima_components($y);

	# byte 0
	$b0.=($y{  1}?'1':'0');
	$b0.=($y{ -1}?'1':'0');
	$b0.=($y{  9}?'1':'0');
	$b0.=($y{ -9}?'1':'0');
	$b0.=($x{ -9}?'1':'0');
	$b0.=($x{  9}?'1':'0');
	$b0.=($x{ -1}?'1':'0');
	$b0.=($x{  1}?'1':'0');

	# byte 1
	$b1.=($y{  3}?'1':'0');
	$b1.=($y{ -3}?'1':'0');
	$b1.=($y{ 27}?'1':'0');
	$b1.=($y{-27}?'1':'0');
	$b1.=($x{-27}?'1':'0');
	$b1.=($x{ 27}?'1':'0');
	$b1.=($x{ -3}?'1':'0');
	$b1.=($x{  3}?'1':'0');

	# byte 2
	$b2.=($jump?'1':'0');
	$b2.='0';
	$b2.=($y{ 81}?'1':'0');
	$b2.=($y{-81}?'1':'0');
	$b2.=($x{-81}?'1':'0');
	$b2.=($x{ 81}?'1':'0');
	$b2.='1';
	$b2.='1';

	# debug
	# print "x: $x => "; foreach (keys %x) { print "$_ "; } print "\n";
	# print "y: $y => "; foreach (keys %y) { print "$_ "; } print "\n";
	# print "$b0 $b1 $b2\n";

	return($b0.$b1.$b2);
}

sub _get_tajima_components {
	my ($n) = @_;
	my ($s,%c);

	for my $p (reverse(0..4)) {
		if($n<0) { $n*=-1; $s=!$s; }
		my $m = 0;
		for my $q (0..$p-1) { $m+=3**$q; }
		if($n>=3**$p-$m) { $n-=3**$p; $c{($s?-1:1)*3**$p}=1; }
	}
	return(%c);
}

sub draw_logo {
	my ($self, $im, @colors) = @_;

	unless(defined($self->{'data'}{'pattern'})) {
		carp("You do not have a pattern to display");
		return 0;
	}

	unless(scalar(@colors) == $self->{'data'}{'color_changes'} + 1) {
		carp($self->{'data'}{'color_changes'} + 1, " colors required, ", scalar(@colors), " colors supplied");
		return 0;
	}

	my ($x, $y); 
	
	if($self->{'ignore_header_coordinates'}) {
		($x, $y) = ( int($self->{'data'}{'x_size'}/2), int($self->{'data'}{'y_size'}/2));
	} else {
		($x, $y) = ($self->{'data'}{'+X'}, $self->{'data'}{'y_size'} - $self->{'data'}{'+Y'});
	}

	my ($new_x, $new_y);

	foreach my $stitch (@{$self->{'data'}{'pattern'}}) {
		if($stitch->[0] == $NORMAL) {
			$new_x = $x + $stitch->[1];
			$new_y = $y - $stitch->[2];
			$im->line($x, $y, $new_x, $new_y, $colors[0]);
			$x = $new_x; $y = $new_y;
		} elsif($stitch->[0] == $JUMP) {
			$x = $x + $stitch->[1];
			$y = $y - $stitch->[2];
		} elsif($stitch->[0] == $COLOR_CHANGE) {
			shift @colors;
		}
	}
	return 1;
}

sub ignore_header_coordinates {
	my ($self, $ignore) = @_;
	
	if(defined($ignore)) {
		$self->{'ignore_header_coordinates'} = $ignore;
	}

	return $self->{'ignore_header_coordinates'};
}

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

	if(defined($label)) {
		$self->{'label'} = $label;
	}
	return $self->{'label'};
}

sub size {
	my ($self) = @_;
	return ($self->{'data'}{'x_size'}, $self->{'data'}{'y_size'});
}

sub get_color_changes {
	my ($self) = @_;
	return $self->{'data'}{'color_changes'};
}

sub get_color_count {
	my ($self) = @_;
	return ($self->{'data'}{'color_changes'} + 1);
}

sub get_stitch_count {
	my ($self) = @_;
	return $self->{'data'}{'stitches'};
}

sub get_end_point {
	my ($self) = @_;
	return ($self->{'data'}{'AX'}, $self->{'data'}{'AY'});
}

sub get_abs_size {
	my ($self) = @_;
	return ($self->{'data'}{'+X'}, $self->{'data'}{'-X'},
		$self->{'data'}{'+Y'}, $self->{'data'}{'-Y'});
}


1;
__END__