File Coverage

blib/lib/Music/Guidonian.pm
Criterion Covered Total %
statement 122 122 100.0
branch 74 74 100.0
condition 52 52 100.0
subroutine 15 15 100.0
pod 3 3 100.0
total 266 266 100.0


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # Music::Guidonian - a means of melodic phrase generation based on the
4             # "Guidonian Hand" that is credited to Guido of Arezzo
5              
6             package Music::Guidonian;
7             our $VERSION = '0.03';
8              
9 2     2   1241 use 5.24.0;
  2         15  
10 2     2   11 use warnings;
  2         4  
  2         69  
11 2     2   10 use Carp 'croak';
  2         5  
  2         144  
12 2     2   13 use List::Util 'shuffle';
  2         4  
  2         222  
13 2     2   1089 use List::UtilsBy 'nsort_by';
  2         4076  
  2         135  
14 2     2   1164 use Moo;
  2         27016  
  2         12  
15 2     2   6147 use namespace::clean;
  2         24309  
  2         13  
16              
17 2     2   638 use constant { INDEX => 0, CHOICE => 1, FIRST => 0, DONE => -1, DIRTY => -1 };
  2         4  
  2         199  
18              
19 2     2   1070 use parent qw(Exporter);
  2         633  
  2         11  
20             our @EXPORT_OK = qw(intervalize_scale_nums);
21              
22             has key2pitch => ( is => 'rw' );
23             has pitchstyle => ( is => 'ro' );
24              
25             # perldoc Moo
26             sub BUILD {
27 22     22 1 38047 my ( $self, $args ) = @_;
28              
29 22 100 100     131 if ( exists $args->{key2pitch} and exists $args->{key_set} ) {
    100          
    100          
30 1         166 croak "cannot specify both key2pitch and key_set";
31              
32             } elsif ( exists $args->{key2pitch} ) {
33             croak "key2pitch must be a hash reference with keys"
34             unless defined $args->{key2pitch}
35             and ref $args->{key2pitch} eq 'HASH'
36 5 100 100     434 and keys $args->{key2pitch}->%*;
      100        
37              
38             } elsif ( exists $args->{key_set} ) {
39 15         44 my $set = $args->{key_set};
40 15 100 100     541 croak "key_set must be a hash reference with keys"
      100        
41             unless defined $set
42             and ref $set eq 'HASH'
43             and keys $set->%*;
44              
45             croak "intervals must be an array with elements"
46             unless defined $set->{intervals}
47             and ref $set->{intervals} eq 'ARRAY'
48 12 100 100     433 and $set->{intervals}->@*;
      100        
49             croak "keys must be an array with elements"
50             unless defined $set->{keys}
51             and ref $set->{keys} eq 'ARRAY'
52 9 100 100     508 and $set->{keys}->@*;
      100        
53             croak "min must be an integer"
54 6 100 100     295 unless defined $set->{min} and $set->{min} =~ m/^(?a)-?\d+$/;
55             croak "max must be an integer"
56 4 100 100     278 unless defined $set->{max} and $set->{max} =~ m/^(?a)-?\d+$/;
57              
58 2 100       126 croak "min must be less than max" if $set->{min} >= $set->{max};
59              
60 1         3 my $curinterval = 0;
61 1         2 my $curkey = 0;
62 1         3 my %key2pitch;
63 1         2 my $pitch = $set->{min};
64              
65 1         2 while (1) {
66 15         20 push @{ $key2pitch{ $set->{keys}->[$curkey] } }, $pitch;
  15         32  
67 15         23 $pitch += $set->{intervals}->[$curinterval];
68 15 100       27 last if $pitch > $set->{max};
69 14         22 $curinterval = ++$curinterval % $set->{intervals}->@*;
70 14         19 $curkey = ++$curkey % $set->{keys}->@*;
71             }
72 1         8 $self->key2pitch( \%key2pitch );
73              
74             # may want to preserve this for reference or cloning?
75 1         3 delete $args->{key_set};
76              
77             } else {
78 1         233 croak "need key2pitch or key_set";
79             }
80              
81 3 100       34 with( $args->{pitchstyle} ) if exists $args->{pitchstyle};
82             }
83              
84             ########################################################################
85             #
86             # METHODS
87              
88             sub iterator {
89 20     20 1 26862 my ( $self, $sequence, %param ) = @_;
90 20 100 100     312 croak "sequence is not an array reference"
91             unless defined $sequence and ref $sequence eq 'ARRAY';
92 18 100       152 croak "sequence is too short" if @$sequence < 2;
93              
94 17 100       49 if ( exists $param{renew} ) {
95             croak "renew is not a code reference"
96             unless !defined $param{renew}
97 4 100 100     116 or ref $param{renew} eq 'CODE';
98             } else {
99 13         37 $param{renew} = \&_renew;
100             }
101              
102 16         49 my $key2pitch = $self->key2pitch;
103 16 100 100     380 croak "no key2pitch map is set"
      100        
104             unless defined $key2pitch
105             and ref $key2pitch eq 'HASH'
106             and keys %$key2pitch;
107              
108             # the possibilities are either scalars (integer pitch numbers, a
109             # static choice) or an [ INDEX, CHOICE ] array reference where the
110             # CHOICE is an array reference of possible integer pitch numbers
111 13         24 my @possible;
112 13         46 for my $i ( 0 .. $#$sequence ) {
113 29         52 my $s = $sequence->[$i];
114 29 100       151 croak "sequence element is undefined ($i)" unless defined $s;
115 28 100       130 if ( $s =~ m/^(?a)-?\d+$/ ) {
116 8         35 push @possible, $s;
117             } else {
118 20   100     65 my $choices = $key2pitch->{$s} // '';
119 20 100       420 croak "choices are not an array reference for '$s'"
120             unless ref $choices eq 'ARRAY';
121 16         23 my $length = $choices->@*;
122 16 100       128 croak "no choices for '$s' at index $i" if $length == 0;
123 15 100       32 if ( $length == 1 ) {
124 1         4 push @possible, $choices->[0];
125 1         3 next;
126             }
127             $param{renew}->( $choices, $i, \@possible, $param{stash} )
128 14 100       58 if defined $param{renew};
129 14         99 push @possible, [ FIRST, $choices ]; # INDEX, CHOICE
130             }
131             }
132              
133             # edge case: there is only one iteration due to a lack of choices.
134             # fail so that the iterator is not complicated to handle that
135 7         17 my $refcount = 0;
136 7 100       13 for my $p (@possible) { $refcount++ if ref $p eq 'ARRAY' }
  18         43  
137 7 100       111 croak "no choices in @possible" if $refcount == 0;
138              
139             return sub {
140 26 100   26   2952 return unless @possible;
141              
142 24         40 my @phrase;
143 24         37 for my $p (@possible) {
144 85 100       159 if ( ref $p eq 'ARRAY' ) {
145 79         152 push @phrase, 0 + $p->[CHOICE][ $p->[INDEX] ];
146             } else {
147 6         15 push @phrase, 0 + $p;
148             }
149             }
150              
151 24         34 my $dirty = 0;
152 24         59 for my $i ( reverse DONE .. $#possible ) {
153 45 100       109 if ( $i == DONE ) {
    100          
154 2         7 @possible = ();
155 2         3 $dirty = 0;
156 2         5 last;
157             } elsif ( ref $possible[$i] eq 'ARRAY' ) {
158 40 100       91 if ( ++$possible[$i][INDEX] >= $possible[$i][CHOICE]->@* ) {
159 18         24 $possible[$i][INDEX] = DIRTY;
160 18         28 $dirty = 1;
161             } else {
162             # nothing more to update (this time)
163 22         38 last;
164             }
165             }
166             }
167 24 100       46 if ($dirty) {
168 8         16 for my $i ( 0 .. $#possible ) {
169 31 100 100     103 if ( ref $possible[$i] eq 'ARRAY' and $possible[$i][INDEX] == DIRTY ) {
170 12         19 $possible[$i][INDEX] = FIRST;
171             $param{renew}->( $possible[$i][CHOICE], $i, \@possible, $param{stash} )
172 12 100       27 if defined $param{renew};
173             }
174             }
175             }
176              
177 24 100       77 if ( defined $self->pitchstyle ) {
178 1         4 for my $p (@phrase) {
179 2         40 $p = $self->pitchname($p);
180             }
181             }
182              
183 24         78 return \@phrase;
184 6         134 };
185             }
186              
187             # this has various problems not typical to melodies, such as confining
188             # leaps towards the end of the phrase in early subsequent iterations.
189             # improvements might be to use a non-random starting pitch (e.g. one
190             # suitable to previous material unknown to the current phrase), or to
191             # sometimes shuffle the choices mid-phrase, or to leap when there is a
192             # repeated note?
193             sub _renew {
194 7     7   26 my ( $choices, $index, $possible ) = @_;
195 7 100       18 if ( $index == 0 ) {
196 3         25 $choices = [ shuffle @$choices ];
197             } else {
198 4         12 my $previous = $possible->[ $index - 1 ];
199 4 100       13 my $previous_pitch =
200             ref $previous eq 'ARRAY'
201             ? $previous->[CHOICE][ $previous->[INDEX] ]
202             : $previous;
203 4     8   31 $choices = [ nsort_by { abs( $previous_pitch - $_ ) } $choices->@* ];
  8         68  
204             }
205             }
206              
207             ########################################################################
208             #
209             # FUNCTIONS
210              
211             # convert Music::Scales "get_scale_nums" to the interval for each step,
212             # making various assumptions (or lack of sanity tests) along the way
213             # (pretty sure I've written this same code elsewhere...)
214             sub intervalize_scale_nums {
215 2     2 1 1529 my ( $scale, $max_interval ) = @_;
216 2   100     12 $max_interval ||= 12; # assume Western 12-tone system
217 2         3 my @intervals;
218 2         6 my $previous = 0;
219 2         5 for my $s (@$scale) {
220 14 100       24 next if $s == 0;
221 12         17 push @intervals, $s - $previous;
222 12         23 $previous = $s;
223             }
224 2         5 push @intervals, $max_interval - $previous;
225 2         8 return \@intervals;
226             }
227              
228             1;
229             __END__