File Coverage

blib/lib/Music/Voss.pm

Criterion	Covered	Total	%
statement	88	104	84.6
branch	29	62	46.7
condition	14	56	25.0
subroutine	17	18	94.4
pod	4	4	100.0
total	152	244	62.3

# -*- Perl -*-
#
# Functions for fractal noise generation functions.
#
# Run perldoc(1) on this file for additional documentation.

package Music::Voss;

use 5.010000;
use strict;
use warnings;
use Carp qw(croak);
use Exporter 'import';
use List::Util ();
use Math::Trig qw(pi);
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.16';

our @EXPORT_OK = qw(bitchange powers powers_stateless weierstrass);

# This method derived from the "White and brown music, fractal curves
# and one-over-f fluctuations" article. Should also be possible with
# physical dice and a binary chart to show how the bits change between
# tries and thus which dice need be re-rolled for a particular try.
sub bitchange {
    my (%params) = @_;
    if ( !exists $params{rollers} ) {
        $params{rollers} = 3;
    } elsif ( !defined $params{rollers} or !looks_like_number $params{rollers} ) {
        croak "rollers must be a number";
    } else {
        $params{rollers} = int $params{rollers};
    }
    if ( !exists $params{roll} ) {
        $params{roll} = sub { int rand 6 };
    } elsif ( !defined $params{roll} or ref $params{roll} ne 'CODE' ) {
        croak "roll must be code reference";
    }
    if ( !exists $params{summer} ) {
        $params{summer} = \&List::Util::sum0;
    } elsif ( !defined $params{summer} or ref $params{summer} ne 'CODE' ) {
        croak "summer must be code reference";
    }
    my @nums = map { $params{roll}->( undef, $_ ) } 0 .. $params{rollers} - 1;
    my $prev;
    return sub {
        my ($n) = @_;
        croak "input must be number" if !defined $n or !looks_like_number $n;
        if ( defined $prev ) {
            for my $rnum ( 0 .. $params{rollers} - 1 ) {
                if ( ( $n >> $rnum & 1 ) != ( $prev >> $rnum & 1 ) ) {
                    $nums[$rnum] = $params{roll}->( $n, $rnum );
                }
            }
        }
        $prev = $n;
        return $params{summer}->(@nums);
    };
}

# "Musimathics, Vol 1" p.358 based function generator based on powers of
# (by default) 2, the supplied number, and a list of subroutines to
# (perhaps) run. (Was called "voss", orginally.)
sub powers {
    my (%params) = @_;
    croak "must be given list of calls"
      if !$params{calls}
      or ref $params{calls} ne 'ARRAY';
    if ( !exists $params{summer} ) {
        $params{summer} = \&List::Util::sum0;
    } elsif ( !defined $params{summer} or ref $params{summer} ne 'CODE' ) {
        croak "summer must be code reference";
    }
    if ( !exists $params{e} ) {
        $params{e} = 2;
    } elsif ( !defined $params{e} or !looks_like_number $params{e} ) {
        croak "e must be a number";
    }
    my @nums = (0) x @{ $params{calls} };
    return sub {
        my ($n) = @_;
        croak "input must be number" if !defined $n or !looks_like_number $n;
        for my $k ( 0 .. $#{ $params{calls} } ) {
            if ( $n % $params{e}**$k == 0 ) {
                $nums[$k] = $params{calls}->[$k]->( $n, $k );
            }
        }
        return $params{summer}->(@nums);
    };
}

sub powers_stateless {
    my (%params) = @_;
    croak "must be given list of calls"
      if !$params{calls}
      or ref $params{calls} ne 'ARRAY';
    if ( !exists $params{summer} ) {
        $params{summer} = \&List::Util::sum0;
    } elsif ( !defined $params{summer} or ref $params{summer} ne 'CODE' ) {
        croak "summer must be code reference";
    }
    if ( !exists $params{e} ) {
        $params{e} = 2;
    } elsif ( !defined $params{e} or !looks_like_number $params{e} ) {
        croak "e must be a number";
    }
    return sub {
        my ($n) = @_;
        croak "input must be number" if !defined $n or !looks_like_number $n;
        my @nums;
        for my $k ( 0 .. $#{ $params{calls} } ) {
            if ( $n % $params{e}**$k == 0 ) {
                push @nums, $params{calls}->[$k]->( $n, $k );
            }
        }
        return $params{summer}->(@nums);
    };
}

# also from "Musimathics, Vol 1" around the same place as the above
sub weierstrass {
    my (%params) = @_;
    if ( !defined $params{r} or !looks_like_number $params{r} ) {
        croak "r must be a number (0 < r <= 1)";
    }
    if ( !defined $params{H} or !looks_like_number $params{H} ) {
        croak "H must be a number (0 < H <= 1)";
    }
    if ( !defined $params{N} or !looks_like_number $params{N} ) {
        croak "N must be a number";
    }
    if ( !exists $params{phase} ) {
        $params{phase} = sub { 0 };
    } elsif ( !defined $params{phase} or ref $params{phase} ne 'CODE' ) {
        croak "phase must be code reference";
    }
    if ( !exists $params{summer} ) {
        $params{summer} = \&List::Util::sum0;
    } elsif ( !defined $params{summer} or ref $params{summer} ne 'CODE' ) {
        croak "summer must be code reference";
    }
    return sub {
        my ( $t, $x ) = @_;
        croak "input must be number" if !defined $t or !looks_like_number $t;
        $x //= 0;
        my @nums;
        for my $k ( 0 .. $params{N} - 1 ) {
            push @nums,
              $params{r}**( $k * $params{H} ) *
              sin(
                $t * pi * $params{r}**( -$k ) + $params{phase}->( $t, $x, $k, %params ) );
        }
        return $params{summer}->(@nums);
    };
}

1;
__END__