File Coverage

blib/lib/Model3D/WavefrontObject.pm

Criterion	Covered	Total	%
statement	97	459	21.1
branch	12	178	6.7
condition	19	78	24.3
subroutine	13	27	48.1
pod	20	21	95.2
total	161	763	21.1

package Model3D::WavefrontObject;

use 5.006;
use strict;

our($VERSION);
$VERSION = 1.00;

use Math::Trig;

sub new {
    my $p = shift;
    my $class = ref $p || $p;
    my $obj = {};
    bless $obj, $class;
    $obj->_init(@_);
    return $obj;
}

sub _init {
    my $obj = shift;

    unless (scalar @_ % 2) {
        while (@_) {
            my $key = shift;
            $obj->{$key} = shift;
        }
    }

    $obj->{v} ||= [];
    $obj->{vt} ||= [];
    $obj->{vn} ||= [];
    $obj->{f} ||= [];
    $obj->{p} ||= [];
    $obj->{l} ||= [];
    $obj->{g} ||= {};
    $obj->{group} ||= {};
    $obj->{mtl} ||= {};
    $obj->{comments} ||= [];
    $obj->{r} ||= {};
    $obj->{_region} ||= 'none';
    $obj->{_material} ||= 'default';
    $obj->{_group} ||= 'NULL';

    if ($obj->{objfile}) {
        $obj->ReadObj($obj->{objfile});
    }

    return 1;
}

sub ReadObj {
    my $obj = shift;
    $obj->{objfile} = shift;
    unless ($obj->{objfile} =~ /\.obj$/ and $obj->{objfile}) {
        $obj->{objfile} .= '.obj';
    }
    unless (-e $obj->{objfile}) {
	return undef;
    }
    if (-d $obj->{objfile}) {
        $obj->{errstr} = "$obj->{objfile} is a directory.";
	return undef;
    }
    unless (-s $obj->{objfile}) {
        $obj->{errstr} = "$obj->{objfile}: File is zero size.";
	unless (-w $obj->{objfile}) {
	    $obj->{errstr} .= " Cannot modify file!";
	}
        return undef;
    }
    my $OBJ;
    unless (open ($OBJ, $obj->{objfile})) {
        $obj->{errstr} = "Can't read $obj->{objfile}: $!";
	return undef;
    }
    my $void = 1;
    my $vpid = 0;
    my $vtoid = 1;
    my $vnoid = 1;
    while (<$OBJ>) {
        chomp;
	s/\r//;
	s/^\s+//;
	s/\s+$//;
	if (/^v\s+/) { # Vertex line
	    /^v\s+([\d\+\-eE\.]+)\s+([\d\+\-eE\.]+)\s+([\d\+\-eE\.]+)\s*([\d\+\-eE\.]*)/;
	    my $x = $1 + 0;
	    my $y = $2 + 0;
	    my $z = $3 + 0;
	    my $wt = $4 + 0 || 1;
	    push @{$obj->{v}}, {x => $x,
	                        y => $y,
				z => $z,
				wt => $wt,
				id => $void,
				pid => $vpid};
	    $void++;
	    $vpid++;
	}
	elsif (/^#\s*r\s+(.*)$/) { # UVMapper Region Extension
	    push @{$obj->{r}}, $1;
	    $obj->{r}->{$1} = 1;
	    $obj->{_region} = $1;
	}
	elsif (/^g$/) { # NULL group declaration
	    my $group = 'NULL';
	    $obj->{g}->{NULL} = 1;
	    $obj->{seengroup}->{$group} = 1;
	    $obj->{_group} = $group;
	}
	elsif (/^g\s+(\S*)$/) { # named group declaration
	    my $group = $1;
	    $group = 'NULL' if lc $group eq '(null)';
	    $obj->{g}->{$group} = 1;
	    $obj->{_group} = $group;
	}
	elsif (/^usemtl\s*(\S*)/) { # Material declaration
	    my $material = $1;
	    $obj->{mtl}->{$material} = '';
	    $obj->{_material} = $material;
	}
	elsif (/^mtllib\s+(.*)\s*$/) { # declare material library
	    my $mtllib = $1;
	    $mtllib =~ s/[\\\:]/\//g;
	    $obj->{mtllib} = $mtllib;
	    $obj->ReadMtlLib;
	}
	elsif (/^vt\s+/) { # UV/UVW line
	    /^vt\s+([\d\+\-eE\.]+)\s+([\d\+\-eE\.]+)\s*([\d\+\-eE\.]*)/;
	    my $u = $1 + 0;
	    my $v = $2 + 0;
	    my $w = $3 + 0;
	    push @{$obj->{vt}}, {u => $u,
	                         v => $v,
				 w => $w,
				 id => $vtoid};
	    $vtoid++;
	}
	elsif (/^vn\s+/) {
	    /^vn\s+([\d\+\-eE\.]+)\s+([\d\+\-eE\.]+)\s+([\d\+\-eE\.]+)/;
	    my $i = $1 + 0;
            my $j = $2 + 0;
	    my $k = $2 + 0;
	    push @{$obj->{vn}}, {i => $i,
	                         j => $j,
				 k => $k,
				 id => $vnoid};
	    $vnoid++;
	}
	elsif (/^fo?\s+(.*)$/) { # Polygon line
	    my $p = $1;
	    my @poly = split " ", $p;
	    my @p;
            for my $pv (@poly) {
	        my ($v, $vt, $vn) = split /\//, $pv;
		# OBJ files are 1-indexed. We want the right element
		# BUT counting backwards is as we expect.
		$v-- if $v > 0;
		$vt-- if $vt > 0;
		$vn-- if $vn > 0;
                push @p, {v => $obj->{v}->[$v],
		          vt => $obj->{vt}->[$vt],
			  vn => $obj->{vn}->[$vn],
			  g => $obj->{_group},
			  m => $obj->{_material},
			  r => $obj->{_region}};
	        push @{$obj->{group}->{$obj->{_group}}},
		       {v => $obj->{v}->[$v],
                        vt => $obj->{vt}->[$vt],
                        vn => $obj->{vn}->[$vn],
                        m => $obj->{_material},
			r => $obj->{_region}}
		  unless $obj->{seengroupv}->{$obj->{_group}}->{$v};
		$obj->{seengroupv}->{$obj->{_group}}->{$v} = 1;
	    }
	    push @{$obj->{f}}, {verts => \@p,
	                        group => $obj->{_group},
				material => $obj->{_material},
				region => $obj->{_region}};

	    # Theoretically, you can now get the x, y, and z coordinates and
	    # UV coordinates and group and material for, say, the third vertex
	    # in the 9th facet like so:

	    #     $x = $obj->{f}->[10]->{verts}->[2]->{v}->{x};
	    #     $y = $obj->{f}->[10]->{verts}->[2]->{v}->{y};
	    #     $z = $obj->{f}->[10]->{verts}->[2]->{v}->{z};
	    #     $g = $obj->{f}->[10]->{group};
	    #     $m = $obj->{f}->[10]->{material};
	    #     $u = $obj->{f}->[10]->{verts}->[2]->{vt}->{u};
	    #     $v = $obj->{f}->[10]->{verts}->[2]->{vt}->{v};

            # Or, to make it even easier:

	    #     $fv = $obj->{f}->[10]->{verts}->[2];
	    #     $y = $fv->{v}->{y};
	    #     $u = $fv->{vt}->{u};
	}
	elsif (/^l\s+(.*)$/) { # Line line
	    my $l = $1;
	    my @line = split " ", $l;
            my @l;
	    for my $lv (@line) {
	        my ($v, $vt) = split /\//, $lv;
		$v-- if $v > 0;
                $vt-- if $vt > 0;
		push @l, {v => $obj->{v}->[$v],
		          vt => $obj->{vt}->[$vt]};
	    }
	    push @{$obj->{l}}, \@l;
	}
	elsif (/^p\s+(.*)$/) { # Point line
	    my $v = $1;
	    $v-- if $v > 0;
	    push @{$obj->{p}}, $v;
	}
	elsif (/^\s*#\s*(.*)$/) { # comment
	    push @{$obj->{comments}}, $1;
	}
    }
    close $OBJ;
    return 1;
}

sub ReadMtlLib {
    my $obj = shift;
    my $mtllib = shift;
    $obj->{mtllib} = $mtllib;
    return undef unless $mtllib;
    my $MTL;
    unless (open ($MTL, "$mtllib")) {
        $obj->{errstr} = "Can't read material library $mtllib.";
	return undef;
    }
    while (<$MTL>) {
        chomp;
	s/\r//;
	s/^\s+//;
	s/\s+$//;
	if (/^newmtl\s+(\S+)/) {
	    $obj->{_defmtl} = $1;
	}
	elsif (/^Ka\s+([\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)/) {
	    my $r = $1;
	    my $g = $2;
	    my $b = $3;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ka}->{r} = $r * 255;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ka}->{g} = $g * 255;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ka}->{b} = $b * 255;
	}
	elsif (/^Kd\s+([\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)/) {
	    my $r = $1;
	    my $g = $2;
	    my $b = $3;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Kd}->{r} = $r * 255;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Kd}->{g} = $g * 255;
            $obj->{mtl}->{$obj->{_defmtl}}->{Kd}->{b} = $b * 255;
	}
	elsif (/^Ks\s+([\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)\s+([[\d\.eE\-\+]+)/) {
	    my $r = $1;
            my $g = $2;
            my $b = $3;
            $obj->{mtl}->{$obj->{_defmtl}}->{Ks}->{r} = $r * 255;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ks}->{g} = $g * 255;
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ks}->{b} = $b * 255;
	}
	elsif (/^illum\s+(\d)/) {
	    $obj->{mtl}->{$obj->{_defmtl}}->{illum} = $1 + 0;
	}
	elsif (/^Ns\s+([\d\.eE\-\+]+)/) {
	    $obj->{mtl}->{$obj->{_defmtl}}->{Ns} = $1 + 0;
	}
	elsif (/^(d|Tr)\s+([\d\.eE\-\+]+)/) {
	    $obj->{mtl}->{$obj->{_defmtl}}->{Tr} = $1 + 0;
	}
	elsif (/^map_Ka\s+(.*)/) {
	    $obj->{mtl}->{$obj->{_defmtl}}->{textureMap} = $1;
	}
    }
    close $MTL;
    return 1;
}

sub Translate {
    my $obj = shift;
    my $trans;
    while (@_) {
        my $axis = shift;
	my $amount = shift;
        $trans->{$axis} = $amount + 0;
    }
    for my $v (@{$obj->{v}}) {
        if ($trans->{x}) {
	    $v->{x} += $trans->{x};
	}
	if ($trans->{y}) {
	    $v->{y} += $trans->{y};
	}
	if ($trans->{z}) {
	    $v->{z} += $trans->{z};
	}
    }
    return 1;
}

sub _getTransCentre {
    my $obj = shift;
    my $centre = {x => 0,
                  y => 0,
		  z => 0};
    my $c = shift;
    return $centre unless $c;
    return $obj->GetNaturalCentre if $c eq 'natural';
    return $obj->GetApparentCentre if $c eq 'apparent';
    my @stdrot = qw(x y z);
    if (ref $c and ref $c ne 'SCALAR') {
        # They can use an arrayref like center => [x,y,z]
	if (ref $c eq 'ARRAY') {
	    for my $p (@{$c}) {
	        my $ax = shift @stdrot;
		$centre->{$ax} = $p;
	    }
	}
	# ...or a hashref like center => {x => x, y => y, z => z}
	elsif (ref $c eq 'HASH') {
	    for my $k (keys %{$c}) {
	        $centre->{$k} = $c->{$k};
            }
	}
    }
    else {
        # Or a scalarref like center => \$center
	if (ref $c and ref $c eq 'SCALAR') {
	    $c = ${$c};
	}
	# or a real scalar in two ways:
	$c =~ s/\s+//g; # (ignoring whitespace)
	my @c = split /,/, $c;
	for my $p (@c) {
	    my ($ax, $r);
	    # Either like 'x:x,y:y,z:z'
	    if ($p =~ /:/) {
	        ($ax, $r) = split /:/, $p;
            }
	    # ...or like 'x,y,z'
	    else {
	        $ax = shift @stdrot;
		$r = $p;
	    }
	    $centre->{$ax} = $r;
	}
    }
    return $centre;
}

sub GetNaturalCentre {
    my $obj = shift;
    my $vcount = scalar @{$obj->{v}};
    my $centre = {x => 0,
                  y => 0,
		  z => 0};
    return $centre unless $vcount;
    my ($x, $y, $z) = (0,0,0);
    for my $v (@{$obj->{v}}) {
        $x += $v->{x};
	$y += $v->{y};
	$z += $v->{z};
    }
    $centre->{x} = $x / $vcount;
    $centre->{y} = $y / $vcount;
    $centre->{z} = $z / $vcount;
    return $centre;
}

sub GetApparentCentre {
    my $obj = shift;
    my $center = {x => 0,
                  y => 0,
		  z => 0};
    return $center unless scalar @{$obj->{v}};
    my ($min, $max) = $obj->MinMax;
    $center->{x} = $max->{x} + $min->{x} / 2;
    $center->{y} = $max->{y} + $min->{y} / 2;
    $center->{z} = $max->{z} + $min->{z} / 2;
    return $center;
}

sub MinMax {
    my $obj = shift;
    my $max = {x => 0,
               y => 0,
               z => 0};
    my $min = {x => 0,
               y => 0,
               z => 0};
    return ($min, $max) unless scalar @{$obj->{v}};
    for my $v (@{$obj->{v}}) {
        $max->{x} = $v->{x} if $v->{x} > $max->{x};
        $min->{x} = $v->{x} if $v->{x} < $min->{x};
        $max->{y} = $v->{y} if $v->{y} > $max->{y};
        $min->{y} = $v->{y} if $v->{y} < $min->{y};
        $max->{z} = $v->{z} if $v->{z} > $max->{z};
        $min->{z} = $v->{z} if $v->{z} < $min->{z};
    }
    return ($min, $max);
}

sub Top {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $max->{y};
}

sub Bottom {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $min->{y};
}

sub Left {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $min->{x};
}

sub Right {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $max->{x};
}

sub Front {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $max->{z};
}

sub Back {
    my $obj = shift;
    my ($min, $max) = $obj->MinMax;
    return $min->{z};
}

sub ReverseWinding {
    my $obj = shift;
    unless (scalar @{$obj->{f}}) {
        $obj->{errstr} = 'This object has no facet information';
	return undef;
    }
    for my $f (@{$obj->{f}}) {
        $f->{verts} = [reverse @{$f->{verts}}];
    }
    return 1;
}

sub Rotate {
    my $obj = shift;
    my $rot;
    while (@_) {
        my $axis = shift;
	my $amount = shift;
	$rot->{$axis} = $amount + 0;
    }
    my $centre = $obj->_getTransCentre($rot->{centre} || $rot->{center});
    return undef unless $rot;
    for my $v (@{$obj->{v}}) {
	if ($centre->{x} || $centre->{y} || $centre->{z}) {
	    if ($centre->{x}) {
	        $v->{x} -= $centre->{x};
	    }
	    if ($centre->{y}) {
	        $v->{y} -= $centre->{y};
	    }
	    if ($centre->{z}) {
	        $v->{z} -= $centre->{z};
	    }
	}
        if ($rot->{x}) {
	    my $rad = Math::Trig::deg2rad($rot->{x});
            my ($rho, $theta, $phi)
	      = Math::Trig::cartesian_to_spherical($v->{y}, $v->{z}, 0);
	    $theta += $rad;
	    ($v->{y}, $v->{z}, undef)
	      = Math::Trig::spherical_to_cartesian($rho, $theta, $phi);
	}
	if ($rot->{y}) {
	    my $rad = Math::Trig::deg2rad($rot->{y});
	    my ($rho, $theta, $phi)
	      = Math::Trig::cartesian_to_spherical($v->{x}, $v->{z}, 0);
	    $theta += $rad;
	    ($v->{x}, $v->{z}, undef)
	      = Math::Trig::spherical_to_cartesian($rho, $theta, $phi);
	}
	if ($rot->{z}) {
	    my $rad = Math::Trig::deg2rad($rot->{z});
	    my ($rho, $theta, $phi)
	      = Math::Trig::cartesian_to_spherical($v->{x}, $v->{y}, 0);
	    $theta += $rad;
	    ($v->{x}, $v->{y}, undef)
	      = Math::Trig::spherical_to_cartesian($rho, $theta, $phi);
	}
        if ($centre->{x} || $centre->{y} || $centre->{z}) {
            if ($centre->{x}) {
                $v->{x} += $centre->{x};
            }
            if ($centre->{y}) {
                $v->{y} += $centre->{y};
            }
            if ($centre->{z}) {
                $v->{z} += $centre->{z};
            }
        }
    }
    return 1;
}

sub _getScaleVal {
    my $obj= shift;
    my $sv = shift;
    return 1 unless $sv;
    my $op;
    $sv =~ s/([\+\-])//;
    $op = $1;
    if ($sv =~ s/\%$//) {
        $sv /= 100;
    }
    if ($op) {
        if ($op eq '-') {
	    $sv = 1 - $sv;
	}
	elsif ($op eq '+') {
	    $sv = 1 + $sv;
	}
    }
    return $sv;
}

sub Scale {
    my $obj = shift;
    my $scale = {x => 1,
                 y => 1,
		 z => 1};
    if (scalar @_ > 1) {
        while (@_) {
            my $axis = shift;
            my $amount = $obj->_getScaleVal(shift);
            $scale->{$axis} = $amount;
        }
    }
    else {
        my $s = shift;
	$scale->{x} = $obj->_getScaleVal($s);
	$scale->{y} = $obj->_getScaleVal($s);
	$scale->{z} = $obj->_getScaleVal($s);
    }
    if ($scale->{scale}) {
        $scale->{scale} = $obj->_getScaleVal($scale->{scale});
        $scale->{x} ||= $scale->{scale};
	$scale->{y} ||= $scale->{scale};
	$scale->{z} ||= $scale->{scale};
    }
    my $centre = $obj->_getTransCentre($scale->{centre} || $scale->{center});
    for my $v (@{$obj->{v}}) {
        $v->{x} *= $scale->{x};
	$v->{y} *= $scale->{y};
	$v->{z} *= $scale->{z};
    }
    return 1;
}

sub GetVertex {
    my $obj = shift;
    my $vert = shift;
    unless ($vert) {
        $obj->{errstr} = 'No vertex specified';
	return undef;
    }
    unless (exists $obj->{v}->[$vert]) {
        $obj->{errstr} = "Vertex $vert does not exist";
	return undef;
    }
    return wantarray ? ($obj->{v}->[$vert]->{x},
                        $obj->{v}->[$vert]->{y},
			$obj->{v}->[$vert]->{z})
		     : $obj->{v}->[$vert];
}

sub GetVertexSpherical {
    my $obj = shift;
    my $vert = shift;
    unless ($vert) {
        $obj->{errstr} = 'No vertex specified';
        return undef;
    }
    unless (exists $obj->{v}->[$vert]) {
        $obj->{errstr} = "Vertex $vert does not exist";
        return undef;
    }
    my $v = $obj->{v}->[$vert];
    my ($rho, $theta, $phi)
     = Math::Trig::cartesian_to_spherical($v->{x}, $v->{y}, $obj->{z});
    $theta = Math::Trig::rad2deg($theta);
    $phi = Math::Trig::rad2deg($phi);
    return wantarray ? ($rho, $theta, $phi) : {rho => $rho,
                                               theta => $theta,
					       phi => $phi};
}

sub Mirror {
    my $obj = shift;
    my $ax = shift;
    $ax ||= 'x';
    for my $v (@{$obj->{v}}) {
        $v->{$ax} = 0 - $v->{ax};
    }
    $obj->ReverseWinding;
    return 1;
}

sub FlipUVs {
    my $obj = shift;
    my $ax = shift;
    $ax ||= 'u';
    for my $vt (@{$obj->{vt}}) {
        $vt->{$ax} = 1 - $vt->{$ax};
    }
    return 1;
}

sub WriteObj {
    my $obj = shift;
    my $outfile = shift || $obj->{outfile};
    $obj->{outfile} = $outfile;

    my $OBJ;
    my $was_stdout = 0;
    if ($obj->{outfile}) {
        open $OBJ, ">$obj->{outfile}";
    }
    else {
        $was_stdout = 1;
        $OBJ = *STDOUT{IO};
    }

    my $prec = $obj->{prec} || 8;

    # Print out file comments
    unshift @{$obj->{comments}},
            "File generated by MapShape.pl (c) Dodger",
	    scalar @{$obj->{v}} . ' Vertices',
	    scalar @{$obj->{vt}} . ' UVs',
	    scalar @{$obj->{f}} . ' Polygons',
	    scalar(keys(%{$obj->{g}})) . ' Groups',
	    scalar(keys(%{$obj->{mtl}})) . 'Materials',
	    scalar(keys(%{$obj->{r}})) . 'Regions';
    for my $comment (@{$obj->{comments}}) {
        print {$OBJ} "# $comment\n";
    }
    print {$OBJ} "\n";

    # Print out vertices
    for my $v (@{$obj->{v}}) {
        my $pf = "v %.${prec}f %.${prec}f %.${prec}f\n";
        printf {$OBJ} $pf, $v->{x}, $v->{y}, $v->{z};
    }
    print {$OBJ} "\n";

    # Print out UVs
    for my $vt (@{$obj->{vt}}) {
        printf {$OBJ} "vt %f %f %f\n", $vt->{u}, $vt->{v}, $vt->{w};
    }
    print {$OBJ} "\n";

    # This is for Poser for now, so no normals.
    # We bailed unless we had UVs, so we assume we have them.
    # There is a slight chance that a model has SOME UVs but not all.
    # Fuck that noise. That's a fucked up improper model, and just rude
    # to do. We're not covering that screwy contingency.

    my ($r, $g, $m);
    for my $f (@{$obj->{f}}) {
        if ($r ne $f->{region}) {
	    $r = $f->{region};
	    print {$OBJ} "# r $r\n";
	}
	if ($g ne $f->{group}) {
	    $g = $f->{group};
	    print {$OBJ} "g $g\n";
	}
	if ($m ne $f->{material}) {
	    $m = $f->{material};
	    print {$OBJ} "usemtl $m\n";
	}
        my $outpoly = join " ",
	                   map "$_->{v}->{id}/$_->{vt}->{id}",
			       @{$f->{verts}};
        print {$OBJ} "f $outpoly\n";
    }
    close $OBJ unless $was_stdout;
    return 1;
}

1;

__END__