File Coverage

blib/lib/Math/SegmentedEnvelope.pm

Criterion	Covered	Total	%
statement	167	180	92.7
branch	78	92	84.7
condition	34	57	59.6
subroutine	33	43	76.7
pod	13	30	43.3
total	325	402	80.8

package Math::SegmentedEnvelope;
# ABSTRACT: create/manage/evaluate segmented (curved) envelope
use Moo;
use Clone 'clone';
use Carp;
use List::Util 'sum';
use constant PI => 4 * atan2(1, 1);
use Exporter::Easy (OK => ['env']);
use namespace::autoclean;

has def => ( is => 'ro', default => sub {  # random by default
    my $size = int rand(5) + 3;
    my $level = shift->border_level;
    [
        [$level->[0], map(rand, (0) x $size), $level->[1]],
        [normalize_sum(map rand() + 0.2, (0) x ($size + 1))],
        [map { (rand(2) + 1) * (int(rand(2))? 1 : -1) } (0) x ($size + 1)]
    ];
});
has border_level => is => rw => default => sub {   # default border level for start and end
    [ (rand)x2 ]
} => coerce => sub {
     ref($_[0]) eq 'ARRAY' ? $_[0] : [($_[0])x2];
};
has is_morph => ( is => 'rw' );
has morpher => (  is => 'rw', default => sub { sub { sin( $_[0] * PI / 2 ) ** 2 } } );
has is_hold => ( is => 'rw' );
has is_fold_over => ( is => 'rw' );
has is_wrap_neg => ( is => 'rw' );

has _duration => ( is => 'rw' );
has _segments => ( is => 'rw' );
has _current_segment => ( is => 'rw', default => sub { 0 } );
has _level_diff => ( is => 'rw' );
has _is_neg => ( is => 'rw' );
has _is_asc => ( is => 'rw' );
has _past_segment => ( is => 'rw', default => sub { -1 } );
has _passed_segments_duration => ( is => 'rw', default => sub { 0 } );

sub env { __PACKAGE__->new(@_) }

sub BUILDARGS {
    my ( $class, @args ) = @_;
    unshift @args, "def" if @args % 2 == 1;
    return { @args };
};

sub BUILD {
    my ($self) = @_;
    croak "size mismatch in envelope definition" if
        @{$self->def->[0]} != @{$self->def->[1]}  + 1
            || @{$self->def->[0]} != @{$self->def->[2]} + 1
                || @{$self->def->[1]} != @{$self->def->[2]};
    $self->_duration(sum(@{$self->def->[1]}));
    $self->_segments(scalar@{$self->def->[1]});
}

sub clean {
    my ($self) = @_;
    $self->_duration(sum(@{$self->def->[1]}));
    $self->_segments(scalar@{$self->def->[1]});
    $self->_current_segment(0);
    $self->_past_segment(-1);
}

sub evaluator {
    my ($self) = @_;
    sub { $self->at(@_) };
}

sub at {
    my ($self, $t) = @_;
    $t = $self->wrap_pos($t);
    my ($pd,$i,$d) = (
        $self->_passed_segments_duration,
        $self->_current_segment
    );
    while ($t < $pd && $i > 0) { $pd -= $self->def->[1]->[--$i] } # backward
    $i == 0 ? $pd = 0 : $t -= $pd;  # remove duration of passed segments
    while ($i < $self->_segments) { # forward - determine segment and cache it for next time
        $d = $self->def->[1]->[$i]; # set current segment duration + error
        if ($t > $d && $i != $self->_segments - 1) { # t passed this segment, so remove this segment duration
            $t -= $d; $pd += $d; $i++; next;
        } else {  # $t is in current segment
            $t = $d if $t > $d;
            $i = $self->update_current_segment($i) unless $i == $self->_past_segment; last;
        }
    }
    # print "r:$i\tt:$t\td:$d\tp:$pd";
    $self->_passed_segments_duration($pd) if $pd != $self->_passed_segments_duration;
    $self->_current_segment($i) if $i != $self->_current_segment;
    abs( # result value
        $self->wrap_value(abs(( $self->_is_neg ? $d - $t : $t ) / $d))
        ** abs($self->def->[2]->[$i])
        * $self->_is_asc
        + $self->_is_neg
    ) * $self->_level_diff + $self->def->[0]->[$i];
    #print "\t$t\n"; $t;
}

sub wrap_value {
    my ($self) = @_;
    $self->is_morph ? $self->morpher->($_[1]) : $_[1]; # value smooth or whatever
}

sub wrap_pos {
    my ($self,$t) = @_;
    my $total = $self->_duration;
    if ($self->is_hold) {
        $t > 0 ? ( $t > $total ? $total : $t ) : 0
    } else {
        my $at = abs($t);
        if ($at > $total) {
            if  ($self->is_fold_over && int($at/$total) % 2 == ( $t < 0 && $self->is_wrap_neg ? 0 : 1 )) { #fold
                ( 1 - ( ($at / $total) - int($at / $total) ) ) * $total;
            } else { # wrap
                ( ($at / $total) - int($at / $total) ) * $total;
            }
        } else { $at }
    };
}

sub update_current_segment {
    my ($self, $i) = @_;
    $i = $self->_current_segment(defined($i) ? $i : ());
    $self->_level_diff($self->level($i+1) - $self->level($i));
    $self->_is_neg($self->curve($i) < 0 ? 1 : 0);
    $self->_is_asc($self->_level_diff < 0 || $self->_is_neg ? -1 : 1);
    $self->_past_segment($i);
}

sub level {
    my $self = shift;
    my $r = $self->def_part_value(0, @_);
    $self->update_current_segment if @_ > 1 && abs($self->_current_segment - ($_[0] >= 0 ? $_[0] : $self->_segments + $_[0])) <= 1;
    $r;
}

sub levels {
    my $self = shift;
    my @r = $self->def_part(0, @_);
    $self->update_current_segment if @_ > 0;
    @r;
}

sub dur {
    my $self = shift;
    my $r = $self->def_part_value(1, @_);
    $self->clean if @_ > 1;
    $r;
}

sub durs {
    my $self = shift;
    my @r = $self->def_part(1, @_);
    $self->clean if @_ > 1;
    @r;
}

sub duration { shift->_duration }
sub segments { shift->_segments }

sub curve {
    my $self = shift;
    my $r = $self->def_part_value(2, @_);
    $self->update_current_segment if @_ > 1 && $self->_current_segment == $_[0];
    $r;
}

sub curves {
    my $self = shift;
    my @r = $self->def_part(2, @_);
    $self->update_current_segment if @_ > 0;
    @r;
}

sub def_part {
    my ($self, $p, @values) = @_;
    (@values == @{$self->def->[$p]} ? $self->def->[$p] = [@values] : carp "size mismatch against initial definition") if @values;
    @{$self->def->[$p]};
}

sub def_part_value {
    my ($self, $p, $at, $value) = @_;
    croak "no such index '$at' in definition part '$p'" if !defined($at) || !exists($self->def->[$p]->[$at]);
    $self->def->[$p]->[$at] = $value if $value;
    $self->def->[$p]->[$at];
}

sub static { # make immutable evaluator from current params
    my ($self) = @_;
    my ($lev, $dur, $cur, $is_smooth, $is_hold, $is_fold_over, $is_wrap_neg, $total) = (
        [$self->levels], [$self->durs], [$self->curves], $self->is_morph && clone($self->morpher),
        $self->is_hold, $self->is_fold_over, $self->is_wrap_neg, $self->duration
    );
    my ($i, $pd, $cs, $level_diff, $is_asc, $is_neg, $d) = (0, 0, -1); # segment index and its data
    my $segment_data = sub {
        $level_diff = $lev->[$i+1] - $lev->[$i];
        $is_neg = $cur->[$i] < 0 ? 1 : 0;
        $is_asc = $level_diff < 0 || $is_neg ? -1 : 1;
        $cs = $i;
    };
    my $wrap_value = $is_smooth ? ( ref($is_smooth) eq 'CODE' ? $is_smooth : sub { sin( PI / 2 * $_[0] ) } ) : sub { $_[0] }; # value smooth or whatever
    my $wrap_pos = $is_hold ? sub {
        $_[0] > 0 ? ( $_[0] > $total ? $total : $_[0] ) : 0;
    } : sub {
        my $t = abs($_[0]);
        if ($t > $total) { #fold
            if ($is_fold_over && int($t/$total) % 2 == ($_[0] < 0 && $is_wrap_neg ? 0 : 1)) {
                (1 - (($t / $total) - int( $t / $total ))) * $total;
            } else { # wrap
                (($t / $total) - int( $t / $total )) * $total;
            }
        } else { $t }
    };
    my $last_segment = @$dur - 1;
    sub {
        my $t = $wrap_pos->($_[0]);
        while ($t < $pd && $i > 0) { $pd -= $dur->[--$i] } # backward
        $i == 0 ? $pd = 0 : $t -= $pd;  # remove duration of passed segments
        while ($i <= $last_segment) { # forward - determine segment and cache it for next tiem
            $d = $dur->[$i]; # set current segment duration
            if ($t > $d && $i != $last_segment) { # t passed this segment, so remove this segment duration
                $t -= $d; $pd += $d; $i++; next;
            } else {  # $t is in current segment
                $t = $d if $t > $d;
                $segment_data->() unless $i == $cs; last;
            }
        }
        #print "r:$i\tt:$t\td:$d\tp:$pd";
        abs( # result value
            $wrap_value->(( $is_neg ? ($d - $t) : $t ) / $d)
            ** abs($cur->[$i])
            * $is_asc
            + $is_neg
        ) * $level_diff + $lev->[$i];
        #print "\t$t\n"; $t;
    }
}

sub table { # create lookup table of specified size, loops and range
    my ($self, $size, $loop, $from, $to) = @_;
    $size ||= 1024;
    $loop ||= 1;
    $from ||= 0;
    $to   ||= $self->duration;
    croak "table size should be >= 1" if $size <= 0;
    my $s = $self->static;
    my $range = $to - $from;
    my $lp = $loop / $size;
    my $p;
    map {
        $p = $_ * $lp;
        $s->($from + $range * ($p - int $p));
    } 0..$size-1;
}

sub normalize_duration {
    my ($self) = @_;
    $self->durs(normalize_sum($self->durs));
    $self;
}

sub normalize_sum {
    my $s = sum@_;
    map $_/$s, @_;
}

# TODO utility methods
sub stack {} # concat?
sub blend {}
sub delay {}
# TODO some usual envelopes
sub adsr {}
sub asr {}
sub cutoff {}
sub perc {}

1;