ac3d2threejs-ok.pl to HTML.

index -|- end

Generated: Sat Oct 12 17:22:38 2013 from ac3d2threejs-ok.pl 2013/05/12 39.9 KB. text copy

#!/usr/bin/perl
# ========================================================================
#< ac3d2threejs.pl - 12/05/2013
# AC3D parser and converter to three.js json format
# Based on ac3d2Horde3D format by Niek Albers, circa 13/11/2009
# 12/05/2013 geoff mclane http://geoffair.net/mperl
# TODO: 
# 1: There are several TODO items noted, mainly where a more strict 
#    parsing would help.
# 2: At present a rought fix in output to ensure a "faces" : [ ] index is 
#    not out of range of the vertices or normals lists, but should address
#    why this happens.
# 3: Should dig into the calculation of the normals. Original code expected 
#    only 3 refs, but have over-ridden this, but with what consequence?
# 4: Would be nice if some of the 'options' below were available on the command
#    line, including for example the output file name.
# ==========================================================================
my $os = $^O;
# This need to be adjusted to suit your environment
my $perl_dir = '.';
my $PATH_SEP = '/';
my $temp_dir = '/tmp';
if ($os =~ /win/i) {
    $perl_dir = '.';
    $temp_dir = '.';
    $PATH_SEP = "\\";
}
unshift(@INC, $perl_dir);   # add location of lib_vec3.pm

my $VERSION = 0.7;  # 12/05/2013 - lots of fixes - geoff
#my $VERSION = 0.6; # last by Niek Albers, circa 13/11/2009

use strict;
no strict 'refs';

#no warnings;
use Data::Dumper;
use Carp;
use File::Copy;
# note: in the original this 'package' was included, but I prefer it separated
require 'lib_vec3.pm' or die "Unable to load 'lib_vec3.pm' Check paths in \@INC...\n";

my $AC3D_FILE_VERSION = 11;

my $strict_triangluation = 0;   # 0=allow any number of SURF refs
my $out_file = $temp_dir.$PATH_SEP."tempscene.xml"; # not really used

# options
my $do_welding = 0;     # not sure what all this was about - it increases the vertices...
my $show_welding = 0;   # now not done - see $do_welding = 0;
my $show_unwelding = 0; # now not done - see $do_welding = 0;

my $show_objects = 1;       # turn off to reduce noise
my $show_calc_norms = 0;    # additional noise
my $show_parse_kid = 0;     # mainly for diagnostics
my $show_parse_numvert = 0; # likewise
my $show_out_of_range = 0;  # show when an index is 'fixed'

my $add_other_items = 0;    # just to see what they are
my $add_line_sep = 1;       # add extra line to the json

my $normal = 0; # grep { $_ eq '-n' } @ARGV;
my $scene_basename;

my $source;
my $ac3dfile;
my $scenefile;
my $geofile;
my @VERTICES;
my @INDICES;
my @NORMALS;
my @TANGENTS;
my @BITANGENTS;
my @TCOORDS0;
my @TCOORDS1;
my @INDPERSURF = ();

my @warnings = ();
my $warn_count = 0; # also used as final exit level

my $index_offset   = 0;
my $batch_offset   = 0;
my $world          = {};
my $material_files = {};
my $last_name      = '';

# my $vertice_count = 0;

# 12/05/2013 - Added token 'subdiv' and 'texoff',
# and changed 'data' to what I understand it does
my $TOKENIZER = {
    'MATERIAL' => \&parse_material,
    'OBJECT'   => \&parse_object,
    'kids'     => \&parse_kids,
    'name'     => \&parse_name,
    'texture'  => \&parse_value,
    'crease'   => \&parse_value,
    'numvert'  => \&parse_numvert,
    'numsurf'  => \&parse_numsurf,
    'SURF'     => \&parse_surf,
    'mat'      => \&parse_mat,
    'refs'     => \&parse_refs,
    'texrep'   => \&parse_texrep,
    'rot'      => \&parse_rot,
    'loc'      => \&parse_loc,
    'url'      => \&parse_value,
    'data'     => \&parse_data,
    'subdiv'   => \&parse_value,
    'texoff'   => \&parse_texoff,
};

# ### DEBUG ###
# Just some vey specific 'test' files, so I can run the script from my editor
# with a blank command line... should be OFF for release
my $debug_on = 0;
#my $def_file = 'C:\FG\18\blendac3d\cube.ac';
#my $def_file = 'C:\FG\18\blendac3d\f16.ac';
#my $def_file = 'C:\FG\fgdata\Aircraft\A380\Models\FlightDeck\Glareshield\efis_c.ac'; # has 'subdiv 1'
#my $def_file = 'C:\FG\fgdata\Aircraft\a4\Models\attitude-mod1.ac'; # has 'texoff -0.5 0.5'
#14398: ac_to_gl: Unrecognised token 'light', line 'OBJECT light'
#my $def_file = 'C:\FG\fgdata\Aircraft\dhc8\Models\dhc8.ac';
#ac_to_gl: Illegal ref record. actually has several blank lines!!! could overlook, but NO!
# Also fails with blender ac importer until blank lines are removed
#my $def_file = 'C:\FG\fgdata\Aircraft\Dromader\Models\DropSystem.ac';
my $def_file = 'C:\FG\ac3d\DropSystem.ac';  # fixed file - no warnings
############################################################################

eval { main(@ARGV) };
die($@) if ($@);
exit($warn_count);

sub prt($) { print shift; }
sub prtw($) { 
    my $t = shift; 
    push(@warnings,$t); 
    prt($t);
}

# simple vector3 class - now an external package
sub vec3 { vec3->new(@_) }

sub basename {
    my $path = shift;
    $path =~ s/.*[\/\\]//;
    return [ split( /\./, $path ) ]->[0];
}

sub filename {
    my $path = shift;
    $path =~ s/.*[\/\\]//;
    return $path;
}

# load a file line, and 'tokenise' it, removing
# any double quotes...
sub parse_line {
    my $line = <$ac3dfile>;
    return if ( !$line );
    my @items = ( $line =~ /(".*?"|\S+)/g );
    map { s/(^"|"$)//g } @items;
    return \@items;

}

# individual opcode parsers

sub parse_header {
    my $items = shift;
    $items->[0] =~ m/^AC3D(\w)/;
    die "not minimally an AC3D version $AC3D_FILE_VERSION file\n"
      if ( hex($1) < $AC3D_FILE_VERSION );
}

sub parse_roc {
    my $items = shift;
    return [
        [ $items->[1], $items->[2], $items->[3] ],
        [ $items->[4], $items->[5], $items->[6] ],
        [ $items->[7], $items->[8], $items->[9] ]
    ];
}

sub parse_value {
    my $items = shift;
    return $items->[1];
}

sub parse_name {
    my $items = shift;
    $last_name = $items->[1];
    return $items->[1];
}

sub parse_texrep {
    my $items = shift;

    return { x => $items->[1], y => $items->[2] };
}

# 12/05/2013 - added
sub parse_texoff {
    my $items = shift;

    return { x => $items->[1], y => $items->[2] };
}


sub parse_surf {
    my $items = shift;

    my $param = hex( $items->[1] );
    my $type  = $param & 0xF;
    my $types = { 0 => 'polygon', 1 => 'closedline', 2 => 'line' };

    my $shading_sides = $param >> 4;

    my $shading = $shading_sides & 0x1 ? 'smooth' : 'flat';
    my $sides   = $shading_sides & 0x2 ? 2        : 1;

    my $result = {
        type    => $types->{$type},
        shading => $shading,
        sides   => $sides,
    };

    return $result;
}

# 12/05/2013 - my 'understanding' is just take the next line, BUT if 
# given a large 'len' could maybe be several lines, but what exactly is
# the spec on this?
sub parse_data {
    my $items = shift;
    my $len = $items->[1];
    my $next = parse_line();
    # TODO: if $strict_ac3d could check the length of the following line = len
    my $result = {
        data => $next
    };
    return $result;
}

sub parse_mat {
    my $items = shift;
    my $index = $items->[1];
    # TODO: if $strict_ac3d could check the index is within range
    return $world->{MATERIAL}->[$index];

}

sub parse_loc {
    my $items = shift;
    # TODO: if $strict_ac3d could check it is 3 floats
    return vec3( $items->[1], $items->[2], $items->[3] );
}

sub parse_numvert {
    my $items    = shift;
    my $numverts = $items->[1];
    my @vertices = ();
    # TODO: if $strict_ac3d could check it is 3 floats
    for ( 1 .. $numverts ) {
        my $itm = parse_line();
        push @vertices, vec3( $itm->[0], $itm->[1], $itm->[2] );
    }
    my $cnt = scalar @vertices;
    warn "parse_numvert: collected $cnt vertices ($numverts)\n" if ($show_parse_numvert);
    return \@vertices;
}

sub parse_refs {
    my $items   = shift;
    my $numrefs = $items->[1];
    # TODO: since source expects just 3 refs, perhaps normals calculation 
    # also needs to be 'fixed' if this is off!
    if ($strict_triangluation) {
        die("model is not triangulated: $last_name numrefs=$numrefs\n") if ( $numrefs != 3 );
    }
    my @indices = ();
    # TODO: if $strict_ac3d could check it is integer, in range, and 2 floats
    for ( 1 .. $numrefs ) {
        my $items = parse_line();
        push @indices,
          { index => $items->[0], u => $items->[1], v => $items->[2] };
    }
    return \@indices;
}

# SURF 0x10
# mat 1
# refs 3
# 1 0.8 1
# 0 1 1
# 5 0.8 0
sub parse_surface {
    my $items   = shift;
    my $surface = {};
    # TODO: if $strict_ac3d could check opcode order, and
    # index into vertices is valid!
    while ( my $items = parse_line() ) {
        my $opcode = $items->[0];
        if ( exists( $TOKENIZER->{$opcode} ) ) {
            $surface->{$opcode} = $TOKENIZER->{$opcode}($items);
        } else {
            my $line = join(" ",@{$items});
            prtw("WARNING: $.: parse_surface: unrecognised opcode [$opcode] in '$line'\n");
        }
        last if ( $surface->{refs} );
    }
    return $surface;
}

sub parse_numsurf {
    my $items    = shift;
    my $numsurfs = $items->[1];
    my @surfaces = ();
    for ( 1 .. $numsurfs ) {
        push @surfaces, parse_surface($items);
    }
    return \@surfaces;
}

sub parse_kids {
    my $items  = shift;
    my $amount = $items->[1];
    my @objects = ();
    warn "parse_kids: $amount...\n" if ($show_parse_kid && $amount);
    for ( 1 .. $amount ) {
        my $items = parse_line();
        push @objects, parse_object($items);
    }
    warn "parse_kids: $amount done\n" if ($show_parse_kid && $amount);
    return \@objects;
}

sub parse_object {
    my $items = shift;

    my $type   = $items->[1];
    my $object = {};
    my $error;
    $last_name = '';
    $object->{type} = $type;
    while ( my $items = parse_line() ) {
        my $opcode = $items->[0];
        if ( exists( $TOKENIZER->{$opcode} ) ) {
            $object->{$opcode} = $TOKENIZER->{$opcode}($items);
            $error = $@ if ($@);
        } else {
            $error = join(" ",@{$items});
            prtw("WARNING: $.: parse_object: unrecognised opcode [$opcode] in '$error'\n");
        }
        last if ( $opcode eq 'kids' );
    }
    warn "parsed object: $object->{name}, type: $type, vertices: "
      . int( @{ $object->{numvert} } ) . "\n" if ($show_objects);
    return $object;
}

sub parse_material {
    my $items = shift;
    # TODO: if $strict_ac3d could check length, and verify tokens
    return {
        name  => $items->[1],
        rgb   => [ $items->[3], $items->[4], $items->[5] ],
        amb   => [ $items->[7], $items->[8], $items->[9] ],
        emis  => [ $items->[11], $items->[12], $items->[13] ],
        spec  => [ $items->[15], $items->[16], $items->[17] ],
        shi   => $items->[19],
        trans => $items->[21],
    };
}

sub parse {

    while ( my $items = parse_line() ) {
        my $command = $items->[0];
        if ( exists( $TOKENIZER->{$command} ) ) {
            push @{ $world->{$command} }, $TOKENIZER->{$command}($items);
        } else {
            my $line = join(" ",@{$items});
            prtw("WARNING: $.: parse: unrecognised command [$command] in '$line'\n");
        }
    }
    return $world;
}

# Original write materials - NOT USED
sub write_material_NOT_USED {
    my $object           = shift;
    my $texture          = $object->{texture} || $scene_basename || 'standard';
    my $texture_basename = basename($texture);
    my $use_normal       = $normal;

    my $material_filename = "$scene_basename/$texture_basename.material.xml";

    return if ( $material_files->{$material_filename} );

    warn "writing to: $material_filename\n";
    my $materialfile;
    mkdir("$scene_basename");
    open( $materialfile, ">$material_filename" )
      || die("Cannot write to $material_filename\n");
    print $materialfile qq~<Material>\n~;
    my $texture_filename = filename($texture);

    warn
      qq~copying "$texture_filename" to "$scene_basename/$texture_filename"\n~;
    copy( $texture_filename, "$scene_basename/$texture_filename" ) || die("$!\n");

    my $texture_normal_filename = $texture_filename;
    $texture_normal_filename =~ s/\.(\w\w\w)$/_normal.$1/;

    if ( !-e "$texture_normal_filename" ) {
        $use_normal = 0;
    }
    else {
        warn
qq~copying "$texture_normal_filename" to "$scene_basename/$texture_normal_filename"\n~;
        copy( $texture_normal_filename, "$scene_basename/$texture_normal_filename" )
          || die("$!\n");
    }

    print $materialfile qq~<Shader source="shaders/model.shader" />\n~;

    if ($texture) {
        if ($use_normal) {
            print $materialfile qq~<ShaderFlag name="_F02_NormalMapping" />\n~;
        }
        print $materialfile
qq~<Sampler name="albedoMap" map="$scene_basename/$texture_filename" />\n~;
        if ($use_normal) {    # add normal mapped texture
            print $materialfile
qq~<Sampler name="normalMap" map="$scene_basename/$texture_normal_filename" />\n~;
        }
    }
    print $materialfile qq~</Material>\n~;
    close($materialfile);
    $material_files->{$material_filename} = 1;
}

# add vertices for indices that point to the same vertex (full unweld)
sub unweld_object_NOT_USED {
    my $object = shift;

    print STDERR "unwelding: $object->{name} " if ($show_unwelding);

    my @tcoords;
    my %found;

    foreach my $surface ( @{ $object->{numsurf} } ) {
        foreach my $ref ( @{ $surface->{refs} } ) {
            if ( $found{ $ref->{index} } ) {

                # add new vertex
                push @{ $object->{numvert} },
                  $object->{numvert}->[ $ref->{index} ];
                $ref->{index} = int( @{ $object->{numvert} } ) - 1;
            }
            $found{ $ref->{index} } = 1;
            $tcoords[ $ref->{index} ] = $ref;
        }
    }
    print STDERR "vertices: " . int( @{ $object->{numvert} } ) . "\n" if ($show_unwelding);

    $object->{tcoords} = \@tcoords;
}

# remove vertices that have the same coordinates, texture coordinates and normals
sub weld_object_NOT_USED {
    my $object = shift;

    print STDERR "welding: $object->{name} " if ($show_welding);

    my @vertices;
    my @normals;
    my @tangents;
    my @bitangents;
    my @tcoords;
    my %found;
    my $index = 0;
    foreach my $surface ( @{ $object->{numsurf} } ) {

        foreach my $ref ( @{ $surface->{refs} } ) {
            my $vertex = $object->{numvert}->[ $ref->{index} ];
            my $normal = $object->{normals}->[ $ref->{index} ];
            my $tcoord = $object->{tcoords}->[ $ref->{index} ];

            my $tangent   = $object->{tangents}->[ $ref->{index} ];
            my $bitangent = $object->{bitangents}->[ $ref->{index} ];
            if ((! defined $vertex)||(! defined $normal)||
                (! defined $tcoord)||(! defined $tangent)||(! defined $bitangent)) {
                warn "weld_object: got undefined suface reference!\n";
                next;
            }

            if (
                !exists(
                    $found{ $vertex->as_string }->{ $normal->as_string }
                      ->{ $tcoord->{u} . ',' . $tcoord->{v} }
                )
              )
            {
                $found{ $vertex->as_string }->{ $normal->as_string }
                  ->{ $tcoord->{u} . ',' . $tcoord->{v} } = $index;

                $vertices[$index]   = $vertex;
                $normals[$index]    = $normal;
                $tcoords[$index]    = $tcoord;
                $tangents[$index]   = $tangent;
                $bitangents[$index] = $bitangent;

                $index++;
            }
            $ref->{index} =
              $found{ $vertex->as_string }->{ $normal->as_string }
              ->{ $tcoord->{u} . ',' . $tcoord->{v} };
        }
    }

    $object->{numvert}    = \@vertices;
    $object->{normals}    = \@normals;
    $object->{tangents}   = \@tangents;
    $object->{bitangents} = \@bitangents;
    $object->{tcoords}    = \@tcoords;

    print STDERR "vertices: " . int( @{ $object->{numvert} } ) . "\n" if ($show_welding);
}

# find lowest and highest vertex index
sub get_min_max_count_index {
    my $object      = shift;
    my $min_index   = 0xffffffff;
    my $max_index   = 0;
    my $index_count = 0;

    foreach my $surface ( @{ $object->{numsurf} } ) {

        foreach my $ref ( @{ $surface->{refs} } ) {
            if ( $max_index < $ref->{index} ) {
                $max_index = $ref->{index};
            }
            if ( $min_index > $ref->{index} ) {
                $min_index = $ref->{index};
            }
            $index_count++;
        }
    }
    return ( $min_index, $max_index, $index_count );
}

# original write object - NOT USED
sub write_object_NOT_USED {
    my $object = shift;

    my $tag    = '';
    my $params = {};

    if ( $object->{loc} ) {
        $params->{tx} = $object->{loc}->x;
        $params->{ty} = $object->{loc}->y;
        $params->{tz} = $object->{loc}->z;
    }

    if ( $object->{type} eq 'world' ) {
        $tag = 'Group';
        $params->{name} = 'world';
    }
    elsif ( $object->{type} eq 'group' ) {
        $tag                = 'Model';
        $params->{name}     = $object->{name};
        $params->{geometry} = "$scene_basename/$scene_basename.geo";
        $object->{in_model} = 1;
    }
    elsif ( $object->{type} eq 'poly' ) {

        if ( !$object->{in_model} )
        {    # whoops not in a model yet, create one first
            my %wrapper = %$object;
            $wrapper{kids} = [$object];
            $wrapper{type} = 'group';
            delete $object->{loc};    # set location for model in this case
            write_object( \%wrapper );
            return;
        }
        else {

            $tag = 'Mesh';

            unweld_object($object);
            calc_vertex_normals($object);
            weld_object($object);

            #            warn Dumper($object);

            my $material = basename( $object->{texture} ) || 'standard';
            $params->{material} = "$scene_basename/$material.material.xml";
            $params->{name}     = $object->{name};

            my ( $min_index, $max_index, $index_count ) =
              get_min_max_count_index($object);

            $params->{vertRStart} = $min_index + $index_offset;
            $params->{vertREnd}   = $max_index + $index_offset;

            $params->{batchCount} = $index_count;
            $params->{batchStart} = $batch_offset;

            write_material($object);

            push @VERTICES,   @{ $object->{numvert} };
            push @NORMALS,    @{ $object->{normals} };
            push @TANGENTS,   @{ $object->{tangents} };
            push @BITANGENTS, @{ $object->{bitangents} };
            push @TCOORDS0,   @{ $object->{tcoords} };
            foreach my $surface ( @{ $object->{numsurf} } ) {
                foreach my $ref ( @{ $surface->{refs} } ) {
                    push @INDICES, $ref->{index} + $index_offset;
                }
            }
            $index_offset += int( @{ $object->{numvert} } );
            $batch_offset += $index_count;

        }
    }

    my $attributes = '';
    foreach my $key ( sort keys(%$params) ) {
        $attributes .= qq~ $key="$params->{$key}"~;
    }
    print $scenefile qq~<$tag$attributes>\n~;
    foreach my $kid ( @{ $object->{kids} } ) {
        $kid->{in_model} = $object->{in_model};
        write_object($kid);
    }
    print $scenefile qq~</$tag>\n~;
    delete $object->{kids};
}

# original write geo - NOT USED
sub write_geo_NOT_USED {

    my $filename = "$scene_basename/$scene_basename.geo";
    open( $geofile, ">$filename" )
      || die("cannot write to $filename\n");
    binmode($geofile);

    warn "writing to: $filename\n";

    print $geofile "H3DG" . pack( 'I', 5 );    # horde file version
    print $geofile pack( 'I', 1 );             # numjoints (0+1)
    print $geofile
      pack( 'f16', 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1 )
      ;                                        # identity matrix

    print $geofile pack( 'I', 6 );                 # num vertex streams
    print $geofile pack( 'I', int(@VERTICES) );    # num vertices

    # Vertices - positions magic = 0
    print $geofile pack( 'I', 0 );

    # streamElementSize 12
    print $geofile pack( 'I', 12 );

    foreach my $vertex (@VERTICES) {
        print $geofile pack( 'f3', $vertex->x, $vertex->y, $vertex->z );
    }

    # Normals - positions magic = 1
    print $geofile pack( 'I', 1 );

    # streamElementSize 6
    print $geofile pack( 'I', 6 );

    foreach my $normal (@NORMALS) {
        print $geofile pack( 's3',
            round( $normal->x * 32767 ),
            round( $normal->y * 32767 ),
            round( $normal->z * 32767 ) );
    }

    # Tangents - positions magic = 2
    print $geofile pack( 'I', 2 );

    # streamElementSize 6
    print $geofile pack( 'I', 6 );

    foreach my $tangent (@TANGENTS) {
        print $geofile pack( 's3',
            round( $tangent->x * 32767 ),
            round( $tangent->y * 32767 ),
            round( $tangent->z * 32767 ) );
    }

    # BiTangents - positions magic = 3
    print $geofile pack( 'I', 3 );

    # streamElementSize 6
    print $geofile pack( 'I', 6 );

    foreach my $bitangent (@BITANGENTS) {
        print $geofile pack( 's3',
            round( $bitangent->x * 32767 ),
            round( $bitangent->y * 32767 ),
            round( $bitangent->z * 32767 ) );
    }

    # texture coordinates set 0 - positions magic = 6
    print $geofile pack( 'I', 6 );

    # streamElementSize 8
    print $geofile pack( 'I', 8 );

    foreach my $tcoord (@TCOORDS0) {
        print $geofile pack( 'f2', $tcoord->{u}, $tcoord->{v} );
    }

    # for now
    @TCOORDS1 = @TCOORDS0;

    # texture coordinates set 1 - positions magic = 7
    print $geofile pack( 'I', 7 );

    # streamElementSize 8
    print $geofile pack( 'I', 8 );
    foreach my $tcoord (@TCOORDS1) {
        print $geofile pack( 'f2', 0, 0 );

        #        print $geofile pack( 'f2', $tcoord->{u}, $tcoord->{v} );
    }

    print $geofile pack( 'I', int(@INDICES) );
    foreach my $index (@INDICES) {
        print $geofile pack( 'I', $index );
    }

    # Morph targets = 0
    print $geofile pack( 'I', 0 );
    close($geofile);

}

# original write scene - NOT USED
sub write_scene_NOT_USED {
    my $tree = shift;
    if (length($out_file)) {
        warn "writing to: $out_file\n";
        open( $scenefile, ">$out_file" )
          || die("Cannot write to $out_file\n");
    } else {
        mkdir($scene_basename);
        my $scene_filename = "$scene_basename/$scene_basename.scene.xml";
        warn "writing to: $scene_filename\n";
        open( $scenefile, ">$scene_filename" )
          || die("Cannot write to $scene_filename\n");
    }
    write_object( $tree->{OBJECT}->[0] );
    close($scenefile);
}

# =================================================================================
###################################################################################
# my three.js replacement fucntions
###################################################################################

sub write_js2 {

    my ($cnt,$i,$msg,$itm,@arr);
    my $filename = $temp_dir.$PATH_SEP."temp.$scene_basename.js";
    open( $geofile, ">$filename" )
      || die("cannot write to $filename\n");

    warn "writing to: $filename\n";
    my $vcnt = scalar @VERTICES;
    my $ncnt = scalar @NORMALS;
    my $scnt = scalar @INDPERSURF;

    $msg = "{\n";
    $msg .= "\n" if ($add_line_sep);
    $msg .= "\t\"metadata\" : {\n";
    $msg .= "\t\t\"formatVersion\" : 3.1,\n";
    $msg .= "\t\t\"generatedBy\"   : \"ac3d2threejs.pl $VERSION\",\n";
    $msg .= "\t\t\"vertices\"      : $vcnt,\n";
    $msg .= "\t\t\"faces\"         : $scnt,\n";
    $msg .= "\t\t\"normals\"       : $ncnt,\n";
    $msg .= "\t\t\"colors\"        : 0,\n";
    $msg .= "\t\t\"uvs\"           : [],\n";
    $msg .= "\t\t\"materials\"     : 1,\n";
    $msg .= "\t\t\"morphTargets\"  : 0,\n";
    $msg .= "\t\t\"bones\"         : 0\n";
    $msg .= "\t},\n";
    $msg .= "\n" if ($add_line_sep);
    $msg .= "\t\"scale\" : 1.000000,\n";
    $msg .= "\n" if ($add_line_sep);
    print $geofile $msg;

    $msg = "\t\"vertices\" : [";
    for ($i = 0; $i < $vcnt; $i++) {
        my $vertex = $VERTICES[$i];
        $msg .= $vertex->x;
        $msg .= ',';
        $msg .= $vertex->y;
        $msg .= ',';
        $msg .= $vertex->z;
        $msg .= "," if (($i + 1) < $vcnt);
    }
    $msg .= "],\n";
    $msg .= "\n" if ($add_line_sep);
    print $geofile $msg;

    print $geofile "\t\"morphTargets\" : [],\n";
    print $geofile "\n" if ($add_line_sep);

    # Normals - positions magic = 1
    $msg = "\t\"normals\"  : [";
    for ($i = 0; $i < $ncnt; $i++) {
        my $normal = $NORMALS[$i];
        next if (!defined $normal);
        $msg .= $normal->x;
        $msg .= ',';
        $msg .= $normal->y;
        $msg .= ',';
        $msg .= $normal->z;
        $msg .= ',' if (($i + 1) < $ncnt);
    }
    $msg .= "],\n";
    print $geofile $msg;
    print $geofile "\n" if ($add_line_sep);

#    foreach my $tcoord (@TCOORDS0) {
#        print $geofile pack( 'f2', $tcoord->{u}, $tcoord->{v} );
#    }
#
#    # for now
#    @TCOORDS1 = @TCOORDS0;
#
#    # texture coordinates set 1 - positions magic = 7
#    print $geofile pack( 'I', 7 );
#
#    # streamElementSize 8
#    print $geofile pack( 'I', 8 );
#    foreach my $tcoord (@TCOORDS1) {
#        print $geofile pack( 'f2', 0, 0 );
#
#        #        print $geofile pack( 'f2', $tcoord->{u}, $tcoord->{v} );
#    }
#
    print $geofile "\t\"colors\" : [],\n";
    print $geofile "\n" if ($add_line_sep);
    print $geofile "\t\"uvs\" : [],\n";
    print $geofile "\n" if ($add_line_sep);

    my ($tmp,$cnt2,$j,$k);
    my ($ind,$emsg);
    $msg = "\t\"faces\"  : [";
    $cnt = scalar @INDPERSURF;
    for ($i = 0; $i < $cnt; $i++) {
        $tmp = $INDPERSURF[$i];
        $msg .= ',' if ($i);
        $cnt2 = scalar @{$tmp};
        $msg .= "35";
        $k = 0;
        for ($j = 0; $j < $cnt2; $j++) {
            $ind = ${$tmp}[$j];
            if (($ind < 0)||($ind >= $vcnt)) {
                $emsg .= "$i:$j: VOOR $ind on $vcnt ";
                $ind = $vcnt - 1;
            }
            $msg .= ",$ind";
            $k++;
            last if ($k == 4);
        }
        while ($k < 4) {
            $msg .= ',0';
            $k++;
        }
        $msg .= ',0';
        $k = 0;
        for ($j = 0; $j < $cnt2; $j++) {
            $ind = ${$tmp}[$j];
            if (($ind < 0)||($ind >= $ncnt)) {
                $emsg .= "$i:$j: $ind/$ncnt ";
                $ind = $ncnt - 1;
            }
            $msg .= ",$ind";
            $k++;
            last if ($k == 4);
        }
        while ($k < 4) {
            $msg .= ',0';
            $k++;
        }
    }
    $msg .= "],\n";
    prtw("WARNING: Out of range index: $emsg\n") if (length($emsg) && $show_out_of_range);
    print $geofile $msg;
    print $geofile "\n" if ($add_line_sep);

   print $geofile "\t\"bones\" : [],\n";
    print $geofile "\n" if ($add_line_sep);

   print $geofile "\t\"skinIndices\" : [],\n";
    print $geofile "\n" if ($add_line_sep);

   print $geofile "\t\"skinWeights\" : [],\n";
    print $geofile "\n" if ($add_line_sep);

   print $geofile "\t\"animation\" : {}";

    if ($add_other_items) {
        # this was just to see what they contained
        print $geofile ",\n";
        print $geofile "\n" if ($add_line_sep);
        @arr = @INDICES;
        $cnt = scalar @arr;
        $msg = "\t\"indices\"  : [";
        for ($i = 0; $i < $cnt; $i++) {
            $itm = $arr[$i];
            $msg = $itm;
            $msg .= ',' if (($i + 1) < $cnt);
        }
        $msg .= "],\n";
        print $geofile $msg;
        print $geofile "\n" if ($add_line_sep);

        @arr = @TANGENTS;
        $cnt = scalar @arr;
        print $geofile "\t\"tangents\" : [";
        for ($i = 0; $i < $cnt; $i++) {
            $itm = $arr[$i];
            $msg = $itm->x;
            $msg .= ',';
            $msg .= $itm->y;
            $msg .= ',';
            $msg .= $itm->z;
            $msg .= ',' if (($i + 1) < $cnt);
            print $geofile $msg;
        }
        print $geofile "],\n";
        print $geofile "\n" if ($add_line_sep);

        @arr = @BITANGENTS;
        $cnt = scalar @arr;
        $msg = "\t\"bitangents\" : [";
        for ($i = 0; $i < $cnt; $i++) {
            $itm = $arr[$i];
            $msg = $itm->x;
            $msg .= ',';
            $msg .= $itm->y;
            $msg .= ',';
            $msg .= $itm->z;
            $msg .= ',' if (($i + 1) < $cnt);
        }
        $msg .= "]\n";
        print $geofile $msg;
        print $geofile "\n" if ($add_line_sep);
    } else {
        print $geofile "\n";
    }

    print $geofile "\n" if ($add_line_sep);
    print $geofile "}\n";

    close($geofile);

    warn "written to: $filename\n";

}

sub write_material2 {
    my $object           = shift;
    my $texture          = $object->{texture} || $scene_basename || 'standard';
    my $texture_basename = basename($texture);
    my $use_normal       = $normal;

    my $material_filename = "$scene_basename/$texture_basename.material.xml";

    return if ( $material_files->{$material_filename} );

    ### warn "writing to: $material_filename\n";
    my $materialfile = $scenefile;
    ###mkdir("$scene_basename");
    ###open( $materialfile, ">$material_filename" )
    ### || die("Cannot write to $material_filename\n");

    print $materialfile qq~<Material>\n~;
    my $texture_filename = filename($texture);

#    warn
#      qq~copying "$texture_filename" to "$scene_basename/$texture_filename"\n~;
#    copy( $texture_filename, "$scene_basename/$texture_filename" ) || die("$!\n");
#
    my $texture_normal_filename = $texture_filename;
    $texture_normal_filename =~ s/\.(\w\w\w)$/_normal.$1/;
#
#    if ( !-e "$texture_normal_filename" ) {
#        $use_normal = 0;
#    }
#    else {
#        warn
#qq~copying "$texture_normal_filename" to "$scene_basename/$texture_normal_filename"\n~;
#        copy( $texture_normal_filename, "$scene_basename/$texture_normal_filename" )
#          || die("$!\n");
#    }
#
    print $materialfile qq~<Shader source="shaders/model.shader" />\n~;

    if ($texture) {
        if ($use_normal) {
            print $materialfile qq~<ShaderFlag name="_F02_NormalMapping" />\n~;
        }
        print $materialfile
qq~<Sampler name="albedoMap" map="$scene_basename/$texture_filename" />\n~;
        if ($use_normal) {    # add normal mapped texture
            print $materialfile
qq~<Sampler name="normalMap" map="$scene_basename/$texture_normal_filename" />\n~;
        }
    }
    print $materialfile qq~</Material>\n~;
    ### close($materialfile);
    $material_files->{$material_filename} = 1;
}


sub write_object2 {
    my $object = shift;

    my $tag    = '';
    my $params = {};

    if ( $object->{loc} ) {
        $params->{tx} = $object->{loc}->x;
        $params->{ty} = $object->{loc}->y;
        $params->{tz} = $object->{loc}->z;
    }

    if ( $object->{type} eq 'world' ) {
        $tag = 'Group';
        $params->{name} = 'world';
    }
    elsif ( $object->{type} eq 'group' ) {
        $tag                = 'Model';
        $params->{name}     = $object->{name};
        $params->{geometry} = "$scene_basename/$scene_basename.geo";
        $object->{in_model} = 1;
    }
    elsif ( $object->{type} eq 'poly' ) {

        if ( !$object->{in_model} )
        {    # whoops not in a model yet, create one first
            my %wrapper = %$object;
            $wrapper{kids} = [$object];
            $wrapper{type} = 'group';
            delete $object->{loc};    # set location for model in this case
            write_object2( \%wrapper );
            return;
        }
        else {

            $tag = 'Mesh';

            unweld_object($object) if ($do_welding);
            calc_vertex_normals($object);
            weld_object($object) if ($do_welding);

            #            warn Dumper($object);

            my $material = basename( $object->{texture} ) || 'standard';
            $params->{material} = "$scene_basename/$material.material.xml";
            $params->{name}     = $object->{name};

            my ( $min_index, $max_index, $index_count ) =
              get_min_max_count_index($object);

            $params->{vertRStart} = $min_index + $index_offset;
            $params->{vertREnd}   = $max_index + $index_offset;

            $params->{batchCount} = $index_count;
            $params->{batchStart} = $batch_offset;

            ### my $vcnt = scalar @{ $object->{numvert} };
            ### my $ncnt = scalar @{ $object->{normals} };

            ### write_material($object);
            write_material2($object);

            ### my $vcnt2 = scalar @{ $object->{numvert} };
            ### my $ncnt2 = scalar @{ $object->{normals} };
            ### warn "Before $vcnt,$ncnt, after $vcnt2,$ncnt2\n";

            push @VERTICES,   @{ $object->{numvert} };
            push @NORMALS,    @{ $object->{normals} };
            push @TANGENTS,   @{ $object->{tangents} };
            push @BITANGENTS, @{ $object->{bitangents} };
            push @TCOORDS0,   @{ $object->{tcoords} };
            # @INDPERSURF
            my @inds = ();
            foreach my $surface ( @{ $object->{numsurf} } ) {
                @inds = ();
                foreach my $ref ( @{ $surface->{refs} } ) {
                    push @INDICES, $ref->{index} + $index_offset;
                    push @inds, $ref->{index} + $index_offset;
                }
                push(@INDPERSURF, [@inds]); # keep on a per face basis
            }
            $index_offset += int( @{ $object->{numvert} } );
            $batch_offset += $index_count;

        }
    }

    my $attributes = '';
    foreach my $key ( sort keys(%$params) ) {
        $attributes .= qq~ $key="$params->{$key}"~;
    }
    print $scenefile qq~<$tag$attributes>\n~;
    foreach my $kid ( @{ $object->{kids} } ) {
        $kid->{in_model} = $object->{in_model};
        write_object2($kid);
    }
    print $scenefile qq~</$tag>\n~;
    delete $object->{kids};
}


sub write_threejs {
    my $tree = shift;
    if (length($out_file)) {
        warn "writing to: $out_file\n";
        open( $scenefile, ">$out_file" )
          || die("Cannot write to $out_file\n");
    } else {
        warn "no out file\n";
        return;
    }
    write_object2( $tree->{OBJECT}->[0] );
    close($scenefile);
    warn "written to: $out_file\n";
}

# =================================================================================
###################################################################################

sub uv_sub {
    my $uv1 = shift;
    my $uv2 = shift;

    return {
        u => $uv1->{u} - $uv2->{u},
        v => $uv1->{v} - $uv2->{v}
    };
}

# find vertices with same coordinates, this is for normal smoothing, return of list of matching indices
sub find_same_vertices {
    my $object      = shift;
    my $indices_map = shift;
    my $index       = shift;

    my $vertex  = $object->{numvert}->[$index];
    my @indices = @{ $indices_map->{ $vertex->as_string } };
    push( @indices, $index ) if ( !grep { $_ == $index } @indices );
    return @indices;
}

# create map of indices with same vertices
sub make_indices_map {
    my $object = shift;

    my %indices_map;

    foreach my $surface ( @{ $object->{numsurf} } ) {

        # only average out smooth vertex normals
        next if ( $surface->{SURF}->{shading} ne 'smooth' );
        foreach my $ref ( @{ $surface->{refs} } ) {

            my $v = $object->{numvert}->[ $ref->{index} ];
            push @{ $indices_map{ $v->as_string } }, $ref->{index};
        }
    }

    #    warn Dumper(\%indices_map);

    return \%indices_map;
}

sub calc_vertex_normals {
    my $object = shift;
    my $vcnt = scalar @{ $object->{numvert} };
    my $scnt = scalar @{ $object->{numsurf} };

    warn "calculating normals: $object->{name} v=$vcnt, s=$scnt\n" if ($show_calc_norms);

    my @normals;
    my @tangents;
    my @bitangents;

    my $indices_map = make_indices_map($object);

    foreach my $surface ( @{ $object->{numsurf} } ) {

        my $index0 = $surface->{refs}->[0]->{index};
        my $index1 = $surface->{refs}->[1]->{index};
        my $index2 = $surface->{refs}->[2]->{index};

        my $v0 = $object->{numvert}->[$index0];
        my $v1 = $object->{numvert}->[$index1];
        my $v2 = $object->{numvert}->[$index2];

        my $d0 = $v1 - $v0;
        my $d1 = $v2 - $v0;
        my $v  = ( $d0 x $d1 )->normalized;

        #
        #  Calculate the normal for this face and add it
        #  to the running sum of normals for each of the
        #  three vertices involved
        #

        # and now tangents and bitangents
        my $Edge0uv = uv_sub( $surface->{refs}->[1], $surface->{refs}->[0] );
        my $Edge1uv = uv_sub( $surface->{refs}->[2], $surface->{refs}->[0] );

        my $cp = $Edge0uv->{u} * $Edge1uv->{v} - $Edge1uv->{u} * $Edge0uv->{v};
        my $r  = 0;
        if ( $cp != 0 ) {
            $r = 1.0 / $cp;
        }

        my $tangent   = ( $d0 * $Edge1uv->{v} - $d1 * $Edge0uv->{v} ) * $r;
        my $bitangent = ( $d1 * $Edge0uv->{u} - $d0 * $Edge1uv->{u} ) * $r;

        my @indices;
        push @indices, find_same_vertices( $object, $indices_map, $index0 );
        push @indices, find_same_vertices( $object, $indices_map, $index1 );
        push @indices, find_same_vertices( $object, $indices_map, $index2 );
        foreach my $index (@indices) {
            $normals[$index]    ||= vec3();
            $tangents[$index]   ||= vec3();
            $bitangents[$index] ||= vec3();

            $normals[$index]    += $v;
            $tangents[$index]   += $tangent;
            $bitangents[$index] += $bitangent;
        }

    }

    #  Normalize and fixup the vertex normal vectors, tangents en bitangents
    my $numVerts = int( @{ $object->{numvert} } );
    for ( my $j = 0 ; $j < $numVerts ; $j++ ) {
        next if (! defined $normals[$j]);
        my $n = $normals[$j]->normalized;
        my $t = $tangents[$j];

        # orthogonalize
        $tangents[$j] = ( $t - $n * ( $n * $t ) )->normalized;
        $normals[$j] = $n;

        if ( ( $n x $t ) * $bitangents[$j] < 0 ) {
            $bitangents[$j] = ( ( $n * -1 ) x $t )->normalized;
        }
        else {
            $bitangents[$j] = ( $n x $t )->normalized;
        }
    }

    $object->{normals}    = \@normals;
    $object->{tangents}   = \@tangents;
    $object->{bitangents} = \@bitangents;
}

sub round {
    my $number = shift;
    return int( $number + .5 * ( $number <=> 0 ) );
}

# TODO: Add more command line options
sub main {
    if ($debug_on) {
        $source = $def_file;
        open( $ac3dfile, "<$source" ) || die "cannot open $source\n";
    } else {
        warn
    "AC3D2Threejs.pl $VERSION - Convert AC3D .ac file to three.js json file.\n";
        $source = pop
          || die
    "usage: $0 <file.ac>\n";
        open( $ac3dfile, "<$source" ) || die "cannot open $source\n";
    }

    $scene_basename = basename($source);
    my $header = parse_line();
    parse_header($header);
    my $tree = parse();

    #### write_scene($tree);
    #### warn Dumper($tree);
    #### write_geo();
    write_threejs($tree);
    write_js2();
    $warn_count = scalar @warnings;
    if ($warn_count) {
        foreach my $w (@warnings) {
            prt($w);
        }
    }
    warn "Done file [$source], lines $., exit $warn_count\n";
    close($ac3dfile);
}

# eof - ac3d2threejs.pl

index -|- top