#! /usr/bin/perl -w

use strict;
use Data::Dumper;

my %handlers = (
    'v'     => \&vert,
    'vn'    => \&norm,
    'vt'    => \&texc,
    'f'     => \&face,
);

=head2 read_obj(filename)

Reads an OBJ file and returns it as an array of hashrefs.  Yeah, one day
this might be a class constructor.

    my @groups = &read_obj("foo.obj");

    my $group = shift @groups
    $group->{'name'};     -- Group name, from "g foobar\n"
    $group->{'verts'};    -- Array of vertices
    $group->{'norms'};    -- Array of vertex normals
    $group->{'texcs'};    -- Array of vertex texture coordinates
    $group->{'faces'};    -- Array of polygons

    my $vert = shift @{$group->{'verts'}};
    $vert->{'x'};       -- x coordinate of $vert.
    $vert->{'y'};       -- y coordinate of $vert.
    $vert->{'z'};       -- z coordinate of $vert.
=cut

sub vert
{
    my ($group, @args) = @_;

    my $vert = {
        'x' => $args[0],
        'y' => $args[1],
        'z' => $args[2],
    };

    push @{$group->{'verts'}}, $vert;
}

=pod
    my $norm = shift @{$group->{'norms'}};
    $norm->{'nx'};      -- x component of $norm.
    $norm->{'ny'};      -- y component of $norm.
    $norm->{'nz'};      -- z component of $norm.
=cut

sub norm
{
    my ($group, @args) = @_;

    my $norm = {
        'nx' => $args[0],
        'ny' => $args[1],
        'nz' => $args[2],
    };

    push @{$group->{'norms'}}, $norm;
}

=pod
    my $texc = shift @{$group->{'texcs'}};
    $texc->{'s'};       -- s coordinate of $texc.
    $texc->{'t'};       -- t coordinate of $texc.
=cut

sub texc
{
    my ($group, @args) = @_;

    my $texc = {
        's' => $args[0],
        't' => $args[1],
    };

    push @{$group->{'texcs'}}, $texc;
}

=pod
    # Eww!
    my $face = shift @{$group->{'faces'}};
    $face == [
        [v, t, n],      -- vert, texc, norm indices for vertex 1
        [v, t, n],      -- vert, texc, norm indices for vertex 2
        ...
        [v, t, n],      -- vert, texc, norm indices for vertex k
    ];
=cut

sub face
{
    my ($group, @args) = @_;

    my $verts = [];
    for (@args) {
        my @vert = split '/';
        push @$verts, \@vert;
    }
    push @{$group->{'faces'}}, $verts;
}


sub read_obj
{
    my ($file) = @_;

    open OBJ, '<', $file
        or die "Can't open $file: $!\n";

    my @groups  = ();
    my $group   = undef;

    while(<OBJ>) {
        next unless /\S/;
        my ($cmd, @args) = split;
 
        # handle groups separately; this is a Red Flag(tm)
        if($cmd eq 'g') {
            push @groups, $group if $group;
            $group = { 'name' => shift @args };
            next;
        }

        # otherwise, use the appropriate function
        my $handler = $handlers{$cmd};
        if(defined $handler) {
            $handler->($group, @args);
        } else {
            warn "Got odd command $cmd with args ",
                 join(' ', @args),
                 " in $file\n";
        }
    }
    push @groups, $group;

    close OBJ
        or die "Can't close $file: $!\n";
    return @groups;
}

sub triangulate_obj
{
    my ($groups) = @_;

    for my $group (@$groups) {
        my $old_faces = $group->{'faces'};
        $group->{'faces'} = [];

        for my $face (@$old_faces) {
            if (scalar @$face == 3) {
                push @{$group->{'faces'}}, $face;
            } elsif (scalar @$face == 4) {
                my $tri_1 = [$face->[0], $face->[1], $face->[2]];
                my $tri_2 = [$face->[0], $face->[2], $face->[3]];
                push @{$group->{'faces'}}, $tri_1, $tri_2;
            } else {
                warn "Don't know how to triangulate a general poly\n";
                push @{$group->{'faces'}}, $face;
            }
        }
    }
}

sub write_obj
{
    my ($file, @groups) = @_;

    open OBJ, '>', $file
        or die "Can't open $file: $!\n";

    print OBJ "# Generated by tri_obj\n\n";

    for my $group (@groups) {
        print OBJ "g ", $group->{'name'}, "\n";

        for my $v (@{$group->{'verts'}}) {
            printf OBJ "v %f %f %f\n", 
                $v->{'x'}, $v->{'y'}, $v->{'z'};
        }

        for my $vn (@{$group->{'norms'}}) {
            printf OBJ "vn %f %f %f\n", 
                $vn->{'nx'}, $vn->{'ny'}, $vn->{'nz'};
        }

        for my $vt (@{$group->{'texcs'}}) {
            printf OBJ "vt %f %f\n", $vt->{'s'}, $vt->{'t'};
        }

        for my $f (@{$group->{'faces'}}) {
            print OBJ "f ";
            for my $vs (@$f) {
                print Dumper $vs;
                print OBJ join('/', @$vs), ' ';
            }
            print OBJ "\n";
        }
    }

    close OBJ
        or die "Can't close $file: $!\n";
}

my @groups = &read_obj($ARGV[0]);
&triangulate_obj(\@groups);
&write_obj('new_'.$ARGV[0], @groups);