File Coverage

blib/lib/Music/Duration/Partition.pm
Criterion Covered Total %
statement 79 86 91.8
branch 14 20 70.0
condition 2 3 66.6
subroutine 17 18 94.4
pod 3 3 100.0
total 115 130 88.4


line stmt bran cond sub pod time code
1             package Music::Duration::Partition;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Partition a musical duration into rhythmic phrases
5              
6             our $VERSION = '0.0813';
7              
8 1     1   1212 use Moo;
  1         11506  
  1         5  
9 1     1   1967 use strictures 2;
  1         1678  
  1         39  
10 1     1   853 use MIDI::Simple ();
  1         21504  
  1         31  
11 1     1   422 use Math::Random::Discrete ();
  1         577  
  1         24  
12 1     1   7 use List::Util qw(min);
  1         2  
  1         99  
13 1     1   459 use namespace::clean;
  1         12116  
  1         6  
14              
15 1     1   335 use constant TICKS => 96;
  1         2  
  1         1307  
16              
17              
18             has durations => (
19             is => 'ro',
20             default => sub { return \%MIDI::Simple::Length },
21             );
22              
23              
24             has size => (
25             is => 'ro',
26             default => sub { return 4 },
27             );
28              
29              
30             has pool => (
31             is => 'ro',
32             isa => sub { die 'Empty pool not allowed' unless ref( $_[0] ) eq 'ARRAY' && @{ $_[0] } > 0 },
33             default => sub { return [ keys %MIDI::Simple::Length ] },
34             );
35              
36             has _min_size => (
37             is => 'ro',
38             builder => 1,
39             lazy => 1,
40             );
41              
42             sub _build__min_size {
43 10     10   76 my ($self) = @_;
44              
45 10         16 my @sizes = map { $self->_duration($_) } @{ $self->pool };
  13         28  
  10         32  
46              
47 10         103 return min(@sizes);
48             }
49              
50             has _mrd => (
51             is => 'ro',
52             builder => 1,
53             lazy => 1,
54             );
55              
56             sub _build__mrd {
57 10     10   69 my ($self) = @_;
58             die 'Sizes of weights and pool not equal'
59 10 100       14 unless @{ $self->weights } == @{ $self->pool };
  10         166  
  10         74  
60 9         133 return Math::Random::Discrete->new($self->weights, $self->pool);
61             }
62              
63              
64             has pool_select => (
65             is => 'rw',
66             builder => 1,
67             lazy => 1,
68             );
69              
70             sub _build_pool_select {
71 10     10   69 my ($self) = @_;
72 10     27   50 return sub { return $self->_mrd->rand };
  27         488  
73             };
74              
75              
76             has weights => (
77             is => 'ro',
78             builder => 1,
79             lazy => 1,
80             );
81              
82             sub _build_weights {
83 7     7   49 my ($self) = @_;
84             # Equal probability for all pool members
85 7         14 return [ (1) x @{ $self->pool } ];
  7         26  
86             }
87              
88              
89             has groups => (
90             is => 'ro',
91             builder => 1,
92             lazy => 1,
93             );
94              
95             sub _build_groups {
96 10     10   67 my ($self) = @_;
97 10         14 return [ (0) x @{ $self->pool } ];
  10         52  
98             }
99              
100             has _pool_group => (
101             is => 'ro',
102             builder => 1,
103             lazy => 1,
104             );
105              
106             sub _build__pool_group {
107 10     10   73 my ($self) = @_;
108              
109 10         17 my %pool_group;
110 10         16 for my $i (0 .. @{ $self->pool } - 1) {
  10         30  
111 13         196 $pool_group{ $self->pool->[$i] } = $self->groups->[$i];
112             }
113              
114 10         55 return \%pool_group;
115             }
116              
117              
118             has remainder => (
119             is => 'ro',
120             default => sub { return 1 },
121             );
122              
123              
124             has verbose => (
125             is => 'ro',
126             default => sub { return 0 },
127             );
128              
129              
130             sub motif {
131 13     13 1 4261 my ($self) = @_;
132              
133 13         23 my $motif = [];
134              
135 13         23 my $format = '%.4f';
136              
137 13         18 my $sum = 0;
138 13         21 my $group_num = 0;
139 13         18 my $group_name = '';
140              
141 13         45 while ( $sum < $self->size ) {
142 38         711 my $name = $self->pool_select->($self); # Chooses a note duration
143              
144             # Compute grouping
145 37 50       995 if ($group_num) {
146 0         0 $group_num--;
147 0         0 $name = $group_name;
148             }
149             else {
150 37 50       605 if ($self->_pool_group->{$name}) {
151 0         0 $group_num = $self->_pool_group->{$name} - 1;
152 0         0 $group_name = $name;
153             }
154             else {
155 37         198 $group_num = 0;
156 37         56 $group_name = '';
157             }
158             }
159              
160 37         78 my $size = $self->_duration($name); # Get the duration of the note
161 37         73 my $diff = $self->size - $sum; # How much is left?
162              
163             # The difference is less than the min_size
164 37 100       695 if (sprintf( $format, $diff ) < sprintf( $format, $self->_min_size )) {
165 3 50       37 warn "WARNING: Leftover duration: $diff\n"
166             if $self->verbose;
167 3 100 66     27 push @$motif, 'd' . sprintf('%.0f', TICKS * $diff)
168             if $self->remainder && sprintf($format, TICKS * $diff) > 0;
169 3         10 last;
170             }
171              
172             # The note duration is greater than the difference
173             next
174 34 50       408 if sprintf( $format, $size ) > sprintf( $format, $diff );
175              
176             # Increment the sum by the note duration
177 34         59 $sum += $size;
178              
179 34 50       74 warn(__PACKAGE__,' ',__LINE__," $name, $size, $sum\n")
180             if $self->verbose;
181              
182             # Add the note to the motif if the sum is less than the total duration size
183 34 50       145 push @$motif, $name
184             if $sum <= $self->size;
185             }
186              
187 12         98 return $motif;
188             }
189              
190              
191             sub motifs {
192 1     1 1 432 my ($self, $n) = @_;
193 1         4 my @motifs = map { $self->motif } 1 .. $n;
  2         5  
194 1         15 return @motifs;
195             }
196              
197              
198             sub add_to_score {
199 0     0 1 0 my ($self, $score, $motif, $pitches) = @_;
200 0         0 for my $i (0 .. $#$motif) {
201 0         0 $score->n($motif->[$i], $pitches->[$i]);
202             }
203             }
204              
205             sub _duration {
206 50     50   91 my ( $self, $name ) = @_;
207              
208 50         65 my $dura;
209              
210 50 100       107 if ($name =~ /^d(\d+)$/) {
211 3         7 $dura = $1;
212             }
213             else {
214 47         93 $dura = $self->durations->{$name};
215             }
216              
217 50         107 return $dura;
218             }
219              
220             1;
221              
222             __END__