File Coverage

blib/lib/Music/RecRhythm.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	16	16	100.0
condition	9	12	75.0
subroutine	16	16	100.0
pod	6	7	85.7
total	124	128	96.8

# -*- Perl -*-
#
# rhythms within rhythms within rhythms
#
# Run perldoc(1) on this file for additional documentation.

package Music::RecRhythm;

use 5.10.0;
use strict;
use warnings;

use List::Util 1.26 qw(sum0);
use Math::BigInt ();
use Moo;
use namespace::clean;
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.04';

with 'MooX::Rebuild';    # for ->rebuild a.k.a. clone

has extra => ( is => 'rw' );
has _next => ( is => 'rw' );
has prev  => ( is => 'rw', weak_ref => 1 );

has set => (
    is     => 'rw',
    coerce => sub {
        my ($set) = @_;
        die "need a set of positive integers"
          if !Music::RecRhythm->validate_set($set);
        for my $n (@$set) {
            $n = int $n;
        }
        return $set;
    },
    trigger => sub {
        my ( $self, $set ) = @_;
        $self->_set_count( scalar @$set );
        $self->_set_sum( sum0(@$set) );
    },
);
has count => ( is => 'rwp' );
has sum   => ( is => 'rwp' );

# flag to skip the callback (though the rhythm will still be present in
# the recursion)
has is_silent => (
    is      => 'rw',
    default => sub { 0 },
    coerce  => sub { $_[0] ? 1 : 0 },
);

sub BUILD {
    my ( $self, $param ) = @_;
    die "need a set of positive integers" if !exists $param->{set};
}

########################################################################
#
# METHODS

sub audible_levels {
    my ($self) = @_;
    my $count = 0;
    while ($self) {
        $count++ unless $self->is_silent;
        $self = $self->next;
    }
    return $count;
}

sub beatfactor {
    my ($self) = @_;
    my %factors;
    my $prev_sum = 1;
    while ($self) {
        my $sum = $self->sum * $prev_sum;
        @factors{ @{ $self->set }, $sum } = ();
        $self     = $self->next;
        $prev_sum = $sum;
    }
    return Math::BigInt->bone()->blcm( keys %factors )->numify;
}

sub levels {
    my ($self) = @_;
    my $count = 0;
    while ($self) {
        $count++;
        $self = $self->next;
    }
    return $count;
}

# TODO could this instead be simplified with a trigger to set prev?
sub next {
    my ( $self, $next ) = @_;
    if ( defined $next ) {
        $self->_next($next);
        $next->prev($self);
        return $self;
    } else {
        return $self->_next;
    }
}

sub recurse {
    my ( $self, $callback, $extra ) = @_;
    my $bf = $self->beatfactor;
    _recurse( $self, $callback, $extra, $bf, 0, 0 );
}

sub _recurse {
    my ( $rset, $callback, $extra, $totaltime, $level, $audible_level, @beats ) =
      @_;
    my %param = ( level => $level, audible_level => $audible_level );
    for my $p (qw/next set/) {
        $param{$p} = $rset->$p;
    }
    my $sil = $rset->is_silent;
    $audible_level++ if !$sil;
    my $unittime = $totaltime / $rset->sum;
    for my $n ( 0 .. $#{ $param{set} } ) {
        $param{beat}     = $param{set}[$n];
        $param{index}    = $n;
        $param{duration} = int( $unittime * $param{beat} );
        if ( !$sil ) {
            $callback->( $rset, \%param, $extra, @beats, $param{beat} );
        }
        if ( defined $param{next} ) {
            _recurse( $param{next}, $callback, $extra, $param{duration}, $level + 1,
                $audible_level, @beats, $param{beat} );
        }
    }
}

sub validate_set {
    my ( $class, $set ) = @_;
    return 0 if !defined $set or ref $set ne 'ARRAY' or !@$set;
    for my $x (@$set) {
        return 0 if !defined $x or !looks_like_number $x or $x < 1;
    }
    return 1;
}

1;
__END__