package Model3D::Poser;

use strict;
use warnings;

our $VERSION = '0.00_01';
$VERSION = eval $VERSION;

our $n;

sub new {
    my $class = ref $_[0] || $_[0]; shift;
    my $self = {};
    while (@_) {
        my ($k, $v) = splice @_, 0, 2;
        $self->{$k} = $v;
    }
    bless $self, $class;
    undef $self->{$_} for qw(_actor _channel _curActor _prevEl);
    return $self;
}

our $t = { cm2 => 'Camera Pose',
           cr2 => 'Character',
           fc2 => 'Face Pose',
           hr2 => 'Hair',
           hd2 => 'Hand Pose',
           lt2 => 'Light Pose',
           mt5 => 'Material',
           mc6 => 'Material Collection',
           pz2 => 'Pose',
           pp2 => 'Prop',
           pz3 => 'Scene' };

sub Read {
    my $self = shift;
    my $file = shift or return undef;

    ($self->{_data}->{filename}, $self->{_data}->{path})
      = map { scalar reverse($_) } split '/', reverse($file), 2;
    ($self->{_data}->{name}, $self->{_data}->{ext})
      = split /\./, $self->{_data}->{filename};
    $self->{_data}->{path} ||= '.';
    $self->{_data}->{type}
      =    $t->{$self->{_data}->{ext}}
        || "@{[$self->{ext} ? qq($self->{_data}->{ext} ) : '']}file";

    $self->{_cur} = [$self->{_data}];
    $self->{_prev} = $self->{_data};

    open my $FILE, $file or return undef;
    $self->readBlock($FILE);
    $self->cleanBlock($self->{_data});
    $self->{_heirarchy}->{root} = $self->assemble($self->{figure}->{root},
                                                  $self->{figure}->{addChild})
       if $self->{figure}
      and ref $self->{figure} eq 'HASH'
      and $self->{figure}->{root}
      and $self->{figure}->{addChild};
    return $self;
}

sub readBlock {
    my $self = shift;
    my $FILE = shift;

    while (<$FILE>) {
        $_ = $self->cleanLine($_) or next;
        next unless $_;
        
        if ($_ eq '}') {
            pop $self->{_cur};
            return;
        }

        if ($_ eq '{') {
            push $self->{_cur}, $self->{_prev};
            $self->readBlock($FILE);
            next;
        }

        my ($name, $val) = split " ", $_, 2;

        my $el = { _element => $name, _value => $val};


        if (grep {$name eq $_} qw(addChild weld)) {
            my $parent;
            $parent = $self->cleanLine($n = <$FILE>) until $parent;
            my ($i, $j);
            ($val, $i) = split /:/, $val;
            ($parent, $j) = split /:/, $parent;
            $el = { child => { actor => $val, index => $i },
                    parent => { actor => $parent, index => $j } };
        }

        if ($name =~ /valueOpDelta/) {
            for my $p (qw(figure controller channel)) {
                $el->{$p} = $self->cleanLine($n = <$FILE>) until $el->{$p};
            }
            my $controller = $el->{controller};
            delete $el->{controller};
            ($el->{controller}->{actor}, $el->{controller}->{index})
              = split /:/, $controller;
            if ($name eq 'valueOpDeltaAdd') {
                my $dad;
                $dad = $self->cleanLine($n = <$FILE>) until $dad;
                (undef, $el->{deltaAddDelta}) = split " ", $dad, 2;
            }
        }

        if (ref $self->{_cur}->[-1] eq 'ARRAY') {
            $self->{_cur}->[-1] = $self->{_cur}->[-1]->[-1];
        }

        if (exists $self->{_cur}->[-1]->{$name}) {
            $self->{_cur}->[-1]->{$name} = [ $self->{_cur}->[-1]->{$name} ]
              unless ref $self->{_cur}->[-1]->{$name} eq 'ARRAY';
            push $self->{_cur}->[-1]->{$name}, $el;
        }
        else {
            $self->{_cur}->[-1]->{$name} = $el;
        }

        $self->{_prev} = $self->{_cur}->[-1]->{$name};

    }
}

sub cleanBlock {
    my $self = shift;
    my $el = shift;

    for my $k (sort byPrefOrder keys %{$el}) {
        next if $k eq 'd' and not $self->{_process_deltas};
        next if $k eq 'v' and not $self->{_process_weight_maps};

        if (    grep { $k eq $_ }
                     qw(root parent inkyParent nonInkyParent)
            and not ref $el->{$k}) {
            $el->{$k} = { actor => $el->{$k} };
            ($el->{$k}->{actor}, $el->{$k}->{index})
              = split /:/, $el->{$k}->{actor}, 2
              if $el->{$k}->{actor} =~ /:/;
        }
        elsif (    grep { $k eq $_ }
                        qw(root parent inkyParent nonInkyParent)
               and ref $el->{$k} eq 'HASH'
               and $el->{$k}->{_value}) {
            $el->{$k} = { actor => $el->{$k}->{_value} };
            ($el->{$k}->{actor}, $el->{$k}->{index})
              = split /:/, $el->{$k}->{actor}
              if $el->{$k}->{actor} =~ /:/;
        }

        if (    ref $el->{$k} eq 'ARRAY'
            and not grep { $k eq $_ }
                         qw(weld addChild addLink linkWeight)) {
            for my $A (grep { ref $_ eq 'HASH' } @{$el->{$k}}) {
                next if $A->{_dupe};
                for my $j (grep { ref $el->{$k}->[$_] eq 'HASH' }
                                grep { $el->{$k}->[$_] != $A }
                                     0..$#{$el->{$k}}) {
                    my $B = $el->{$k}->[$j];
                    if ($B->{_value} eq $A->{_value}) {
                        for my $p (keys $B) {
                            $A->{$p} = $B->{$p};
                            $B->{_dupe} = 1;
                        }
                    }
                }
            }

            $el->{$k} = [grep { ref $_ eq 'HASH' ? not $_->{_dupe} : 1 }
                              @{$el->{$k}}];
            $el->{$k} = $el->{$k}->[0] if @{$el->{$k}} == 1;
        }

        if (grep { $k eq $_ } qw(prop actor light camera controlProp)) {
            my @actors = ref $el->{$k} eq 'ARRAY' ? @{$el->{$k}} : ($el->{$k});
            for my $A (grep { ref $_ eq 'HASH' } @actors) {
                ($A->{_name}, $A->{index}) = split /:/, $A->{_value};
                delete $A->{_value};
                $self->{_actor}->{$A->{index} || 0}->{$A->{_name}} = $A;
            }
        }

        if (ref $el->{$k} eq 'HASH') {
            if (    keys $el->{$k} == 2
                and (   exists $el->{$k}->{_value}
                     or exists $el->{$k}->{_name})) {
                if (exists $el->{$k}->{_value}) {
                    $el->{$k} = $el->{$k}->{_value};
                }
                else { $el->{$k} = $el->{$k}->{_name} }
            }
            else {
                $el->{$k}->{_name} = $el->{$k}->{_value}
                  if defined $el->{$k}->{_value};
                delete $el->{$k}->{_value};
                delete $el->{$k}->{_element};
                $self->{_prevEl} = $el;
                $self->cleanBlock($el->{$k});
            }

            if (    ref $el->{$k} eq 'HASH'
                and exists $el->{$k}->{_name}
                and $el->{$k}->{_name} =~ /:/) {
                ($el->{$k}->{_name}, $el->{$k}->{index})
                  = split /:/, $el->{$k}->{_name}, 2;
            }

            if (    ref $el->{$k} eq 'HASH'
                and keys $el->{$k} == 2
                and $el->{$k}->{actor}
                and exists $el->{$k}->{index}) {
                if ($self->{_actor}->{   $el->{$k}->{index}
                                      || 0}->{$el->{$k}->{actor}}) {
                    $el->{$k}
                      = $self->{_actor}->{   $el->{$k}->{index}
                                          || 0}->{$el->{$k}->{actor}};
                }
                else {
                    $el->{$k}->{_not_found} = 1;
                }
            }
        }

        if (ref $el->{$k} eq 'ARRAY') {
            if (@{$el->{$k}} == 1) {
                $el->{$k} = $el->{$k}->[0];

                $self->{_curActor} = $el->{$k}
                  if     ref $el->{$k} eq 'HASH'
                     and keys $el->{$k} > 2
                     and grep { $k eq $_ }
                              qw(prop actor light camera controlProp);

                $self->{_prevEl} = $el;
                $self->cleanBlock($el->{$k});
            }
            else {
                for my $i (grep { ref $el->{$k}->[$_] eq 'HASH' }
                                0..$#{$el->{$k}}) {
                    my $E = $el->{$k}->[$i];
                    if (    keys $E == 2
                        and (   exists $E->{_value}
                             or exists $E->{_name})) {
                        if (exists $E->{_value}) {
                            $el->{$k}->[$i] = $E->{_value};
                        }
                        else { $el->{$k}->[$i] = $E->{_name} }
                    }
                    else {
                        $E->{_name} = $E->{_value} if defined $E->{_value};
                        delete $E->{_value};
                        delete $E->{_element};
                        $self->{_curActor} = $E
                          if     ref $E eq 'HASH'
                             and keys $E > 2
                             and grep { $k eq $_ } 
                                      qw(prop actor light camera controlProp);
                        $self->{_prevEl} = $el;
                        $self->cleanBlock($E);
                    }
                }
            }

            if ($k eq 'd') {
                my $dl;
                for my $d (@{$el->{$k}}) {
                    my ($v, $x, $y, $z) = split " ", $d, 4;
                    $dl->{$v} = { x => $x, y => $y, z => $z };
                }
                $el->{$k} = $dl;
            }

            if ($k eq 'v') {
                my $vl;
                for my $v (@{$el->{$k}}) {
                    my ($vi, $w) = split " ", $v, 2;
                    $vl->{$vi} = $w;
                }
                $el->{$k} = $vl;
            }
        }

        if ($k eq 'deltas' and ref $el->{$k}->{d} eq 'HASH') {
            $el->{$k} = $el->{$k}->{d};
        }

        unless (ref $el->{$k}) {
            unless ($el->{$k} =~ /[^\d.eE\-]/) {
                $el->{$k} += 0 if $el->{$k} =~ /\d/;
            }

            if (    $el->{$k} =~ /\s/
                and $el->{$k} !~ /[^\d.eE\-\s]/
                and $el->{$k} =~ /\d/) {
                $el->{$k} = [map { $_ + 0 } split " ", $el->{$k}];
                $el->{$k} = { x => $el->{$k}->[0],
                              y => $el->{$k}->[1],
                              z => $el->{$k}->[2] }
                  if @{$el->{$k}} == 3;
            }

            if (    $k eq 'channel'
                and ref $self->{_prevEl} eq 'HASH'
                and $self->{_prevEl}->{controller}
                and ref $self->{_prevEl}->{controller} eq 'HASH') {
                my $prevChan = $self->{_prevEl}->{controller}->{channels};

                if (ref $prevChan eq 'HASH') {
                    for my $c (grep { ref $prevChan->{$_} eq 'HASH' }
                                    keys $prevChan) {
                        if ($prevChan->{$c}->{_value} eq $el->{$k}) {
                            $el->{$k} = $prevChan->{$c};
                            last;
                        }
                    }
                }
                elsif (ref $prevChan eq 'ARRAY') {
                    for my $channel (@{$prevChan}) {
                        if ($channel->{_value} eq $el->{$k}) {
                            $el->{$k} = $channel;
                            last;
                        }
                    }
                }
            }
        }
    }
}

sub assemble {
    my $self = shift;
    my ($root, $add) = @_;
    my $heir = { actor => $root, children => [] };
    $add = [$add] unless ref $add eq 'ARRAY';

    for my $part (@{$add}) {
        if ($part->{parent} == $root) {
            push $heir->{children},
                 grep { $_ }
                      $self->assemble($part->{child},
                                      [grep { $_ != $part } @{$add}]);
        }
    }

    delete $heir->{children} unless scalar @{$heir->{children}};
    return $heir;
}

sub cleanLine {
    my $self = shift;
    my $line = shift;
    chomp $line;
    $line =~ s/[\r\n]//g;
    $line =~ s/^\s+|\s+$//g;
    return $line;
}

our $order = {
    version => 1,
    figureResFile => 2,
    actor => 3,
    prop => 4,
    camera => 4,
    controlProp => 4,
      storageOffset => 4.01,
      geomHandlerGeom => 4.02,
      name => 4.03,
      off => 4.04,
      on => 4.04,
      bend => 4.04,
      animatableOrigin => 4.05,
      dynamicsLock => 4.06,
      hidden => 4.07,
      addToMenu => 4.08,
      castsShadow => 4.09,
      includeInDepthCue => 4.10,
      useZBuffer => 4.11,
      parent => 4.12,
      creaseAngle => 4.13,
      subdivLevels => 4.14,
      subdivRenderLevels => 4.15,
      channels => 4.16,
    figure => 1,
};

sub byPrefOrder {
    ($order->{$a} || 1000000) <=> ($order->{$b} || 1000000)
}


1;

__END__
=encoding utf8
=head1 NAME

Model3D::Poser - Perl extension for reading and manipulating Poser content files

=head1 SYNOPSIS

  use Model3D::Poser;
  my $pz = new Model3D::Poser;
  $pz->Read('/private/var/lib/Runtime/Libraries/Character/Whatever/Figure.cr2');

=head1 DESCRIPTION

This is a work-in-progress. It reads basic things but there are all sorts of goofy exceptions
in the Poser content format that aren't covered (like falloff zones, just as a for instance)

Also if you enable the delta and weight map parsing on a figure with a lot of those, it will
get hella slow. Seeing if there's a way to speed that up. I'm sure there is.

=head1 HISTORY

=over 8

=item 0.00_01

Just started this. But feel free to mess with it. No manipulatoin or output methods exisy
yet and it will frell up on some stuff (see above).

=back



=head1 SEE ALSO

Model3D::WavefrontObject which is not yet required in this module but will be, eventually,
to handle geomCustom (which is currently just going to be a big messy arrayref I reckon).

=head1 AUTHOR

Sean Dodger Cannon, E<lt>dodger@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright ©2016 by Sean Dodger Cannon

This library is free software; you can redistribute it and/or modify
 t under the same terms as Perl itself, either Perl version 5.18.2 or,
at your option, any later version of Perl 5 you may have available.


=cut
