File Coverage

blib/lib/Lego/Ldraw/Line.pm

Criterion	Covered	Total	%
statement	49	254	19.2
branch	1	72	1.3
condition	1	7	14.2
subroutine	15	50	30.0
pod	1	30	3.3
total	67	413	16.2

package Lego::Ldraw::Line;

use 5.008004;
use strict;
use warnings;

no warnings qw(uninitialized redefine);
use overload
  '""'  => \&stringify,
  '*'   => \&transform;

use Carp;
use YAML;
use Lego::Ldraw;
use Data::Dumper;
use Math::MatrixReal;
use File::Basename;

my $line_formats = [
		    [qw(type command)],
		    [qw(type colour x y z a b c d e f g h i part)],
		    [qw(type colour x1 y1 z1 x2 y2 z2)],
		    [qw(type colour x1 y1 z1 x2 y2 z2 x3 y3 z3)],
		    [qw(type colour x1 y1 z1 x2 y2 z2 x3 y3 z3 x4 y4 z4)],
		    [qw(type colour x1 y1 z1 x2 y2 z2 x3 y3 z3 x4 y4 z4)]
		   ];

our $config;
our %descriptions;

#######################################################################
# Constructors
#######################################################################

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

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

sub new_from_string {
  my $self  = shift->new;

  my $line = shift;
  for ($line) {
    s/\s+$//; s/^\s+//;
  }

  my @line = split ' ', $line;
  @line = ($line[0], join (' ', @line[1..$#line])) unless ($line[0]); # handle comment lines

  my @fields = @{$line_formats->[$line[0]]};
  @{$self}{@fields} = @line;

  return $self;
}

sub new_from_part_name {
  my $self = shift;
  my $part = shift;

  return $self->new_from_string('1 16 0 0 0 1 0 0 0 1 0 0 0 1 ' . $part);
}

#######################################################################
# Field access functions
#######################################################################

sub BEGIN {
  #--------------------------------------------------
  # Use generated functions for clarity and speed,
  # with exceptions...
  #--------------------------------------------------
  my @field_list = ('colour', 'a'..'i', 'x', 'y', 'z',
		    'x1', 'y1', 'z1', 'x2', 'y2', 'z2',
		    'x3', 'y3', 'z3', 'x4', 'y4', 'z4');
  no strict 'refs';
  for my $field (@field_list) {
    *$field = sub {
      my $self = shift;
      return unless exists $self->{$field};
      if (@_) {
	$self->{$field} = shift;
	return $self->{$field};
      } else {
	return $self->{$field};
      }
    }
  }
  use strict 'refs';
}

#--------------------------------------------------
# ...because of uppercasing
#--------------------------------------------------
sub part {
  my $self = shift;
  return unless exists $self->{'part'};
  my $part = $self->{part};
  $part =~ s/\\/\//g;
  return lc $part;
}

sub name {
  return basename(shift->part);
}

#--------------------------------------------------
# ...because it's read-only
#--------------------------------------------------
sub type {
  return shift->{type};
}

#--------------------------------------------------
# ...because of spelling
#--------------------------------------------------
sub color {
  shift->colour(@_);
}

#######################################################################
# other field access functions
#######################################################################

sub copy {
  my $self = shift;
  return bless { %{$self} }, ref $self;
}

sub fields {
  return @{$line_formats->[ shift->type ]}
}

sub model {
  my $self = shift;
  if (@_) {
    $self->{model} = shift;
  }
  return $self->{model};
}

sub description {
  my $self = shift;
  return unless $self->type == 1;

  return $descriptions{$self->part};
}


sub values {
  my $self = shift;
  my @fields = @_;
  @fields = $self->fields unless @fields;
  return @{$self}{ @fields }
}

sub coords {
    my $self = shift;
    my @fields = grep { /^[xyz]/ } $self->fields;
    return $self->values(@fields);
}

sub points {
  my $points = shift->type;
  return $points > 4 ? 4 : $points;
}

sub transform_matrix {
    my $self = shift;
    return unless ($self->type == 1);

    my @fields = grep { /^[a-ixyz]$/ } $self->fields;
    return $self->values(@fields);
}

sub point {
  my $self = shift;
  my $point = shift;
  return unless my $type = $self->type;

  if ($type == 1) {
    return $self->values(qw(x y z));
  } else {
    return $self->values(map { $_ . $point } qw(x y z))
  }
}

sub format {
  my $self = shift;

  my @text = $self->values;

  for ($self->type) {
    /^0/ && do  {
      return "$self";
    };
    /^1/ && do {
      my $string = "%d %7d";
      for (2..$#text-1) {
	$string .= "% 8.2f";
      }
      $string .= " %12s";
      return sprintf $string, @text;
    };
    my $string = "%d";
    for (1..$#text) {
      $string .= "% 8.2f";
    }
    return sprintf $string, @text;
  }
}

sub eval {
    my $self = shift;
    my $expr = shift;

    $expr = lc $expr;
    $expr =~ s/color/colour/g;

    # substitute % strings with field accesses,
    # and while doing so check if field exists:
    # if it doesn't return undef
    while ($expr =~ s/\%([a-z0-9]+)/\$self->{$1}/) {
	return unless defined $self->$1;
    }

    # substitute & strings with function calls,
    # and while doing so check if function exists:
    # if it doesn't return undef
    while ($expr =~ s/\&(\w+)/\$self->$1/) {
	return unless defined $self->can($1);
    }

    # now we've got a full eval'uable string, and
    # we eval it
    if (eval $expr) {
      return $self
    } else {
      return
    }
}

#######################################################################
# inlining
#######################################################################

sub normalize {
  my $self = shift;
  return unless $self->type == 1;

  @{$self}{qw/x y z a b c d e f g h i/} = qw/0 0 0 1 0 0 0 1 0 0 0 1/;
  return $self;
}

sub dir {
  my $self = shift;
  $self->{dir} = shift if @_;
  return $self->{dir};
}

sub partfile {
  my $self = shift;
  return unless $self->type == 1;

  my $part = $self->part;
  return $self->config->{partfiles}->{$part}
    if $self->config->{partfiles}->{$part};

  my $base = $self->config->{base};

  my @parts = @{$self->config->{parts}};
  @parts = map { $_ = $base . $_ . $part } @parts;

  @parts = ('./' . $part, $self->dir . '/' . $part, @parts);

  for (@parts) {
    s/\\/\//g;
    if (-e $_) {
      $self->config->{partfiles}->{$part} = $_;
      return $_;
    }
  }
}

sub explode {
  my $self = shift;

  return unless $self->type == 1;

  my $file = $self->partfile;

  return unless $file;
  return Lego::Ldraw->new_from_file($file);
}

sub traslate {
  my $self = shift;
  my %trans;

  if (ref $_[0] eq 'HASH') { %trans = %{ $_[0] } }
  else { @trans{qw(x y z)} = @_ };

  for my $axis (keys %trans) {
    for my $field ( grep { /^$axis/ } $self->fields ) {
      $self->{$field} += $trans{$axis}
    }
  }
  return $self;
}

sub transform {
  my $self = shift;
  my $line = shift;

  return unless $self->type;
  return unless $line->type == 1;

  $self->color($line->color) if $self->color == 16;
  my $m = $line->_transform_matrix;

  if ($self->type == 1) {
    my $x = $self->_transform_matrix();
    $self->_transform_matrix($x * $m);
  } else {
    for (1..$self->points) {
      my $p = $self->_xyz_matrix(undef, $_);
      $self->_xyz_matrix($p * $m, $_)
    }
  }
}

#######################################################################
# other stuff
#######################################################################

sub stringify {
  my $self = shift;
  my $type = $self->type;

  my @fields = @{$line_formats->[$self->type]};
  return join ' ', @{$self}{@fields};
}

#######################################################################
# matrix calculation
#######################################################################

sub _xyz_matrix {
  my $self = shift;
  my $matrix = shift;

  if ($matrix) {
    my $point = $self->type == 1 ? undef : shift;
    my @fields = map { $_ . $point } ('x', 'y', 'z');

    $matrix->each( sub {
		     my $field = shift @fields;
		     return unless $field;
		     $self->$field(shift)
		   } );

    return $self;
  } else {
    my @point  = $self->point(shift);
    my $matrix = Math::MatrixReal->new(1, 4);
    $matrix->[0] = [ [ @point, 1 ] ];
    return @point ? $matrix : undef;
  }
}

sub _transform_matrix {
  my $self = shift;
  my $matrix = shift;

  if ($matrix) {
    my @fields = (qw(a d g), undef,
		  qw(b e h), undef,
		  qw(c f i), undef,
		  qw(x y z), undef);

    $matrix->each( sub {
		     my $field = shift @fields;
		     return unless $field;
		     $self->$field(shift)
		   } );
    return $self;
  } else {
    my $matrix = Math::MatrixReal->new(4, 4);
    $matrix->[0] = [
		    [ $self->values( qw(a d g) ), 0 ],
		    [ $self->values( qw(b e h) ), 0 ],
		    [ $self->values( qw(c f i) ), 0 ],
		    [ $self->values( qw(x y z) ), 1 ]
		   ];
    return $matrix;
  }
}

###############################################################
# configuration stuff
###############################################################

sub INIT {
  return if $config;
  $config = do { local $/;  };
  $config = Load($config);

  $config->{base} = $ENV{'LDRAWDIR'};
  open DESCRIPTIONS, $config->{base} . 'parts.lst' || return;
  while () {
    chop;
    my ($part, $description) = unpack 'A14A*', $_;
    $descriptions{$part} = $description;
  }
}

sub config {
  return $config;
}

sub basedir {
  local $_ = $config->{base};
  s/\/$//;
  s/\\$//;
  return $_;
}

sub partsdirs {
  my $self = shift;
  my @d = @{$config->{parts}};
  my $base = $self->basedir;

  for (@d) {
    $_ = join ('/', $base, $_)
      unless /^\./;
    s/\/$//;
    s/\\$//;
  }
  return @d;
}

sub primitives {
  return %{$config->{primitives}}
}

###############################################################
# faster constructor for Matrix::Real
###############################################################

sub Math::MatrixReal::new {
    my ($proto, $rows, $cols) =  @_;

    my $class = ref($proto) || $proto || 'Math::MatrixReal';
    my($i, $j, $this);

    $this = [ [ ], $rows, $cols ];

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

###############################################################
# end of faster constructor for Matrix::Real
###############################################################

1;

__DATA__