File Coverage

blib/lib/Music/Chord/Progression/Transform.pm
Criterion Covered Total %
statement 131 134 97.7
branch 26 36 72.2
condition 3 3 100.0
subroutine 19 20 95.0
pod 2 2 100.0
total 181 195 92.8


line stmt bran cond sub pod time code
1             package Music::Chord::Progression::Transform;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Generate transformed chord progressions
5              
6             our $VERSION = '0.0303';
7              
8 1     1   1284 use Moo;
  1         11069  
  1         6  
9 1     1   1821 use strictures 2;
  1         1596  
  1         38  
10 1     1   722 use Algorithm::Combinatorics qw(variations);
  1         3475  
  1         62  
11 1     1   8 use Carp qw(croak);
  1         2  
  1         107  
12 1     1   529 use Data::Dumper::Compact qw(ddc);
  1         12977  
  1         5  
13 1     1   584 use Music::NeoRiemannianTonnetz ();
  1         3521  
  1         24  
14 1     1   452 use Music::Chord::Note ();
  1         1144  
  1         31  
15 1     1   427 use Music::Chord::Namer qw(chordname);
  1         2740  
  1         68  
16 1     1   445 use Music::MelodicDevice::Transposition ();
  1         66405  
  1         33  
17 1     1   8 use namespace::clean;
  1         3  
  1         11  
18              
19             with 'Music::PitchNum';
20              
21              
22             has base_note => (
23             is => 'ro',
24             isa => sub { croak "$_[0] is not a valid note" unless $_[0] =~ /^[A-G][#b]?$/ },
25             default => sub { 'C' },
26             );
27              
28              
29             has base_octave => (
30             is => 'ro',
31             isa => sub { croak "$_[0] is not a valid octave" unless $_[0] =~ /^[1-8]$/ },
32             default => sub { 4 },
33             );
34              
35              
36             has chord_quality => (
37             is => 'ro',
38             default => sub { '' },
39             );
40              
41              
42             has base_chord => (
43             is => 'lazy',
44             init_arg => undef,
45             );
46              
47             sub _build_base_chord {
48 8     8   72 my ($self) = @_;
49 8         36 my $cn = Music::Chord::Note->new;
50 8         80 my @chord = $cn->chord_with_octave(
51             $self->base_note . $self->chord_quality,
52             $self->base_octave
53             );
54 8         904 return \@chord;
55             }
56              
57              
58             has format => (
59             is => 'ro',
60             isa => sub { croak "$_[0] is not a valid format" unless $_[0] =~ /^(?:ISO|midinum)$/ },
61             default => sub { 'midinum' },
62             );
63              
64              
65             has semitones => (
66             is => 'ro',
67             isa => sub { croak "$_[0] is not a valid number of semitones" unless $_[0] =~ /^[1-9]\d*$/ },
68             default => sub { 7 },
69             );
70              
71              
72             has max => (
73             is => 'ro',
74             isa => sub { croak "$_[0] is not a valid maximum" unless $_[0] =~ /^[1-9]\d*$/ },
75             default => sub { 4 },
76             );
77              
78              
79             has allowed => (
80             is => 'ro',
81             isa => sub { croak "$_[0] is not valid" unless ref $_[0] eq 'ARRAY' },
82             default => sub { [qw(T N)] },
83             );
84              
85              
86             has transforms => (
87             is => 'ro',
88             isa => sub { croak "$_[0] is not a valid transform" unless ref $_[0] eq 'ARRAY' || $_[0] =~ /^[1-9]\d*$/ },
89             default => sub { 4 },
90             );
91              
92              
93             has verbose => (
94             is => 'ro',
95             isa => sub { croak "$_[0] is not a boolean" unless $_[0] =~ /^[01]$/ },
96             default => sub { 0 },
97             );
98              
99             has _nrt => (
100             is => 'lazy',
101             );
102              
103             sub _build__nrt {
104 5     5   73 return Music::NeoRiemannianTonnetz->new;
105             }
106              
107             has _mdt => (
108             is => 'lazy',
109             );
110              
111             sub _build__mdt {
112 6     6   145 return Music::MelodicDevice::Transposition->new;
113             }
114              
115              
116             sub generate {
117 7     7 1 3092 my ($self) = @_;
118              
119             # get the pitch-nums of the base_chord - static and mutable
120 7         22 my ($pitches, $notes) = $self->_get_pitches;
121              
122             # get either the defined transformations or a random set
123 7         20 my @transforms = $self->_build_transform;
124              
125 7 50       24 $self->_initial_conditions(@transforms) if $self->verbose;
126              
127 7         16 my @chords;
128             my @generated;
129 7         13 my $i = 0;
130              
131 7         15 for my $token (@transforms) {
132 23         39 $i++;
133              
134             # perform the transformation
135 23         56 my $transformed = $self->_build_chord($token, $pitches, $notes);
136              
137 23         51 my @notes = map { $self->pitchname($_) } @$transformed; # for ISO
  77         744  
138 23         236 my @base = map { s/^([A-G][#b]?)\d/$1/r } @notes; # for chord-name
  77         279  
139              
140             # tally what has been generated
141 23 100       85 push @generated, $self->format eq 'ISO' ? \@notes : $transformed;
142              
143 23         56 my $chord = _sanitize_chordname(@base);
144 23         55 push @chords, $chord;
145              
146 23 50       81 printf "%d. %s: %s %s %s\n",
147             $i, $token,
148             ddc($transformed), ddc(\@notes),
149             $chord
150             if $self->verbose;
151              
152             # "increment" our pitches
153 23         70 $notes = $transformed;
154             }
155              
156 7         38 return \@generated, \@transforms, \@chords;
157             }
158              
159              
160             sub circular {
161 1     1 1 446 my ($self) = @_;
162              
163             # get the pitch-nums of the base_chord - static and mutable
164 1         5 my ($pitches, $notes) = $self->_get_pitches;
165              
166             # get either the defined transformations or a random set
167 1         9 my @transforms = $self->_build_transform;
168              
169 1 50       17 $self->_initial_conditions(@transforms) if $self->verbose;
170              
171 1         5 my @chords;
172             my @generated;
173 1         3 my $posn = 0;
174              
175 1         9 for my $i (1 .. $self->max) {
176 4         13 my $token = $transforms[ $posn % @transforms ];
177              
178             # perform the transformation
179 4         11 my $transformed = $self->_build_chord($token, $pitches, $notes);
180              
181 4         13 my @notes = map { $self->pitchname($_) } @$transformed; # for ISO
  12         112  
182 4         41 my @base = map { s/^([A-G][#b]?)\d/$1/r } @notes; # for chord-name
  12         49  
183              
184             # tally what has been generated
185 4 50       24 push @generated, $self->format eq 'ISO' ? \@notes : $transformed;
186              
187 4         10 my $chord = _sanitize_chordname(@base);
188 4         15 push @chords, $chord;
189              
190 4 50       16 printf "%d. %s (%d): %s %s %s\n",
191             $i, $token, $posn % @transforms,
192             ddc($transformed), ddc(\@notes),
193             $chord
194             if $self->verbose;
195              
196             # "increment" our pitches
197 4         6 $notes = $transformed;
198              
199             # move left or right at random
200 4 100       30 $posn = int rand 2 ? $posn + 1 : $posn - 1;
201             }
202              
203 1         44 return \@generated, \@transforms, \@chords;
204             }
205              
206             sub _sanitize_chordname {
207 27     27   70 my (@notes) = @_;
208              
209 27         86 my $chord = chordname(@notes);
210              
211             # fix mangled/unknown chordnames
212 27         111811 $chord =~ s/\s+//;
213 27         71 $chord =~ s/o/dim/;
214 27         41 $chord =~ s/maj/M/;
215 27         45 $chord =~ s/sus7/7sus4/;
216 27         45 $chord =~ s/7adda5/7(#5)/;
217 27         42 $chord =~ s/7addb2/7(b9,13)/;
218 27         40 $chord =~ s/9add13/7(9,13)/;
219 27         42 $chord =~ s/7addm10/7(#9)/;
220 27 50       90 $chord = $1 . $2 if $chord =~ /^(.+)\/(\d+)$/;
221             # ...and there are probably more to come...
222              
223 27         80 return $chord;
224             }
225              
226             sub _get_pitches {
227 8     8   16 my ($self) = @_;
228 8         15 my @pitches = map { $self->pitchnum($_) } @{ $self->base_chord };
  26         984  
  8         193  
229 8         396 return \@pitches, [ @pitches ];
230             }
231              
232             sub _initial_conditions {
233 0     0   0 my ($self, @transforms) = @_;
234 0         0 printf "Initial: %s%s %s\nTransforms: %s\n",
235             $self->base_note, $self->base_octave, $self->chord_quality,
236             join(',', @transforms);
237             }
238              
239             sub _build_transform {
240 8     8   42 my ($self) = @_;
241              
242 8         18 my @t; # the transformations to return
243              
244 8 100       49 if (ref $self->transforms eq 'ARRAY') {
    50          
245 5         13 @t = @{ $self->transforms };
  5         18  
246             }
247             elsif ($self->transforms =~ /^\d+$/) {
248 3         11 my @transforms = qw(O I);
249              
250 3 50       5 if (grep { $_ eq 'T' } @{ $self->allowed }) {
  6         23  
  3         26  
251 3         13 push @transforms, (map { 'T' . $_ } 1 .. $self->semitones); # positive
  21         50  
252 3         10 push @transforms, (map { 'T-' . $_ } 1 .. $self->semitones); # negative
  21         45  
253             }
254 3 50       9 if (grep { $_ eq 'N' } @{ $self->allowed }) {
  6         16  
  3         12  
255 3 50       13 if ($self->chord_quality eq 7) {
256 0         0 push @transforms, qw(
257             S23 S32 S34 S43 S56 S65
258             C32 C34 C65
259             );
260             }
261             else {
262 3         10 my @alphabet = qw(P R L);
263 3         8 push @transforms, @alphabet;
264              
265 3         22 my $iter = variations(\@alphabet, 2);
266 3         195 while (my $v = $iter->next) {
267 18         252 push @transforms, join('', @$v);
268             }
269              
270 3         32 $iter = variations(\@alphabet, 3);
271 3         198 while (my $v = $iter->next) {
272 18         202 push @transforms, join('', @$v);
273             }
274             }
275             }
276              
277 3         38 @t = map { $transforms[ int rand @transforms ] }
  11         81  
278             1 .. $self->transforms;
279             }
280              
281 8         26 return @t;
282             }
283              
284             sub _build_chord {
285 27     27   69 my ($self, $token, $pitches, $notes) = @_;
286              
287 27         40 my $chord;
288              
289 27 100       136 if ($token =~ /^O$/) {
    100          
    100          
290 2         5 $chord = $pitches; # return to the original chord
291             }
292             elsif ($token =~ /^I$/) {
293 4         9 $chord = $notes; # no transformation
294             }
295             elsif ($token =~ /^T(-?\d+)$/) {
296 14         45 my $semitones = $1;
297 14         312 $chord = $self->_mdt->transpose($semitones, $notes);
298             }
299             else {
300 7 100 100     67 my $task = $self->_nrt->taskify_tokens($token)
301             if length $token > 1 && $token !~ /\d/;
302 7 100       71 my $op = defined $task ? $task : $token;
303              
304 7         166 $chord = $self->_nrt->transform($op, $notes);
305             }
306              
307 27         15669 return $chord;
308             }
309              
310             1;
311              
312             __END__