| File: | blib/lib/Music/NWC2MusicXML/Score.pm |
| Coverage: | 90.2% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Music::NWC2MusicXML::Score; | |||||
| 2 | ||||||
| 3 | 16 16 16 | 262 7 66 | use strict; | |||
| 4 | 16 16 16 | 10 8 210 | use warnings; | |||
| 5 | ||||||
| 6 | our $VERSION = '0.002.4'; | |||||
| 7 | ||||||
| 8 | 16 16 16 | 11 6 171 | use Carp qw(croak carp); | |||
| 9 | 16 16 16 | 17 8 235 | use List::Util qw(any); | |||
| 10 | 16 16 16 | 22 7 119 | use Readonly; | |||
| 11 | 16 16 16 | 13 8 132 | use Scalar::Util qw(blessed); | |||
| 12 | 16 16 16 | 13 4 100 | use Params::Validate::Strict qw(validate_strict); | |||
| 13 | 16 16 16 | 11 9 97 | use Params::Get; | |||
| 14 | 16 16 16 | 1336 13 5357 | use Music::NWC2MusicXML::Staff; | |||
| 15 | ||||||
| 16 | Readonly::Hash my %MESSAGES => ( | |||||
| 17 | error_bad_staff => 'add_staff: argument must be a Music::NWC2MusicXML::Staff, got: %s', | |||||
| 18 | error_no_staves => 'Score contains no staves', | |||||
| 19 | error_internal => 'Internal error: %s', | |||||
| 20 | warn_empty_staff => "Staff '%s' has no events", | |||||
| 21 | warn_bar_duration => "Staff '%s', measure %d: duration %s quarter-notes does not match time signature (%s expected)", | |||||
| 22 | warn_unmatched_tie => "Staff '%s': unterminated tie from position '%s'", | |||||
| 23 | warn_unclosed_slur => "Staff '%s': slur arc not closed at end of staff", | |||||
| 24 | ); | |||||
| 25 | ||||||
| 26 | # Recognised SongInfo keys that map to MusicXML metadata elements | |||||
| 27 | Readonly::Array my @SONGINFO_KEYS => qw( | |||||
| 28 | Title | |||||
| 29 | Author | |||||
| 30 | Lyricist | |||||
| 31 | Copyright | |||||
| 32 | Copyright1 | |||||
| 33 | Copyright2 | |||||
| 34 | Comments | |||||
| 35 | ); | |||||
| 36 | ||||||
| 37 - 77 | =head1 NAME
Music::NWC2MusicXML::Score - Internal representation of a complete NWC score.
=head1 VERSION
0.002.4
=head1 SYNOPSIS
use Music::NWC2MusicXML::Score;
my $score = Music::NWC2MusicXML::Score->new(
metadata => { Title => 'To a Pilgrim', Author => 'Trad, Arr Nigel Horne' },
page_setup => { StaffSize => 16, Zoom => 3 },
);
$score->add_staff($staff_object);
my $staves = $score->staves;
=head1 DESCRIPTION
C<Music::NWC2MusicXML::Score> is the root of the internal representation tree.
It holds:
=over 4
=item * B<metadata> -- SongInfo fields (Title, Author, Lyricist, Copyright, Comments).
=item * B<page_setup> -- PgSetup fields, retained but largely informational.
=item * B<properties> -- additional score-level NWC properties.
=item * B<staves> -- ordered list of C<Music::NWC2MusicXML::Staff> objects.
=back
This class is MusicXML-agnostic; it describes the musical content in NWC
terms. The C<Music::NWC2MusicXML::MusicXML> generator translates it to XML.
=cut | |||||
| 78 | ||||||
| 79 | sub new { | |||||
| 80 | 341 | 42172 | my ($class, %input) = @_; | |||
| 81 | 341 | 776 | my $args = validate_strict( | |||
| 82 | schema => { | |||||
| 83 | metadata => { type => 'hashref', optional => 1, default => {} }, | |||||
| 84 | page_setup => { type => 'hashref', optional => 1, default => {} }, | |||||
| 85 | properties => { type => 'hashref', optional => 1, default => {} }, | |||||
| 86 | nwc_version => { type => 'scalar', optional => 1 }, | |||||
| 87 | }, | |||||
| 88 | input => \%input, | |||||
| 89 | ); | |||||
| 90 | 339 | 19202 | croak $@ unless defined $args; | |||
| 91 | ||||||
| 92 | my $self = bless { | |||||
| 93 | _metadata => $args->{metadata}, | |||||
| 94 | _page_setup => $args->{page_setup}, | |||||
| 95 | _properties => $args->{properties}, | |||||
| 96 | _nwc_version => $args->{nwc_version}, | |||||
| 97 | 339 | 504 | _staves => [], | |||
| 98 | _fonts => [], | |||||
| 99 | }, $class; | |||||
| 100 | ||||||
| 101 | 339 | 20451 | return $self; | |||
| 102 | } | |||||
| 103 | ||||||
| 104 | # --------------------------------------------------------------------------- | |||||
| 105 | # Accessors | |||||
| 106 | # --------------------------------------------------------------------------- | |||||
| 107 | ||||||
| 108 - 119 | =head2 metadata Return the metadata hashref. Keys correspond to NWC SongInfo field names: C<Title>, C<Author>, C<Lyricist>, C<Copyright>, C<Comments>. =head3 Returns Hashref. =cut | |||||
| 120 | ||||||
| 121 | 625 | 1396 | sub metadata { return $_[0]->{_metadata} } | |||
| 122 | ||||||
| 123 - 127 | =head2 page_setup Return the page-setup hashref (NWC PgSetup fields). =cut | |||||
| 128 | ||||||
| 129 | 277 | 311 | sub page_setup { return $_[0]->{_page_setup} } | |||
| 130 | ||||||
| 131 - 135 | =head2 properties Return additional score-level properties hashref. =cut | |||||
| 136 | ||||||
| 137 | 2 | 6 | sub properties { return $_[0]->{_properties} } | |||
| 138 | ||||||
| 139 - 144 | =head2 nwc_version Return the NWC version string extracted from the NWCTXT header (e.g. C<2.751>), or undef if not available. =cut | |||||
| 145 | ||||||
| 146 | 13 | 201 | sub nwc_version { return $_[0]->{_nwc_version} } | |||
| 147 | ||||||
| 148 - 153 | =head2 fonts Return the arrayref of font descriptors parsed from NWC Font records. Each entry is a hashref with keys: style, typeface, size, bold, italic. =cut | |||||
| 154 | ||||||
| 155 | 194 | 193 | sub fonts { return $_[0]->{_fonts} } | |||
| 156 | ||||||
| 157 - 175 | =head2 set_metadata_field Set a single metadata field. =head3 Arguments =over 4 =item C<$key> -- field name (e.g. C<Title>). =item C<$value> -- string value. =back =head3 Returns C<$self>. =cut | |||||
| 176 | ||||||
| 177 | sub set_metadata_field { | |||||
| 178 | 301 | 203 | my ($self, $key, $value) = @_; | |||
| 179 | 301 | 188 | $self->{_metadata}{$key} = $value; | |||
| 180 | 301 | 136 | return $self; | |||
| 181 | } | |||||
| 182 | ||||||
| 183 | # --------------------------------------------------------------------------- | |||||
| 184 | # Staff management | |||||
| 185 | # --------------------------------------------------------------------------- | |||||
| 186 | ||||||
| 187 - 245 | =head2 add_staff Append a C<Music::NWC2MusicXML::Staff> to the score's staff list. =head3 Purpose Called by the parser each time it encounters an C<AddStaff> record; the staff object is populated with subsequent per-staff records and then stays in the list for MusicXML generation. =head3 Arguments =over 4 =item C<$staff> -- a blessed C<Music::NWC2MusicXML::Staff> object (required). =back =head3 Returns C<$self> (for chaining). =head3 Side Effects Appends to C<_staves>. =head3 Usage Example $score->add_staff( Music::NWC2MusicXML::Staff->new(name => 'Violin I') ); =head3 API SPECIFICATION =head4 Input $staff : Music::NWC2MusicXML::Staff (required) =head4 Output $self (Music::NWC2MusicXML::Score) =head3 MESSAGES | Code | Meaning | Resolution | |----------------|----------------------------------|------------------------------| | error_bad_staff| Argument is not a Staff object | Construct Staff before adding | =head3 FORMAL SPECIFICATION [AddStaff] DeltaScore staff? : Staff --------- staves' = staves ^ <staff?> (placeholder -- populate with Z calculus as implementation matures) =cut | |||||
| 246 | ||||||
| 247 | sub add_staff { | |||||
| 248 | 521 | 1033 | my ($self, $staff) = @_; | |||
| 249 | 521 | 995 | croak _fmt_msg('error_bad_staff', ref($staff) // 'SCALAR') | |||
| 250 | unless blessed($staff) && $staff->isa('Music::NWC2MusicXML::Staff'); | |||||
| 251 | 507 507 | 255 288 | push @{ $self->{_staves} }, $staff; | |||
| 252 | 507 | 443 | return $self; | |||
| 253 | } | |||||
| 254 | ||||||
| 255 - 273 | =head2 staves Return an arrayref of all C<Music::NWC2MusicXML::Staff> objects in score order. =head3 Returns Arrayref of C<Music::NWC2MusicXML::Staff>. =head3 API SPECIFICATION =head4 Input (none) =head4 Output ARRAYREF of Music::NWC2MusicXML::Staff =cut | |||||
| 274 | ||||||
| 275 | sub staves { | |||||
| 276 | 643 | 654 | my ($self) = @_; | |||
| 277 | 643 | 599 | return $self->{_staves}; | |||
| 278 | } | |||||
| 279 | ||||||
| 280 - 285 | =head2 current_staff Return the last staff appended (the one currently being populated by the parser), or undef if no staves have been added. =cut | |||||
| 286 | ||||||
| 287 | sub current_staff { | |||||
| 288 | 1220361 | 303922 | my ($self) = @_; | |||
| 289 | 1220361 | 389443 | return $self->{_staves}[-1]; | |||
| 290 | } | |||||
| 291 | ||||||
| 292 - 296 | =head2 staff_count Return the number of staves. =cut | |||||
| 297 | ||||||
| 298 | sub staff_count { | |||||
| 299 | 251 | 3544 | my ($self) = @_; | |||
| 300 | 251 251 | 139 309 | return scalar @{ $self->{_staves} }; | |||
| 301 | } | |||||
| 302 | ||||||
| 303 - 336 | =head2 validate Perform consistency checks on the score structure. Called when C<--validate> is passed on the command line. =head3 Purpose Checks that every staff has at least one event, that tie/slur relationships are consistent, and that measure durations match the current time signature. =head3 Returns Arrayref of diagnostic strings (empty on success). =head3 API SPECIFICATION =head4 Input (none) =head4 Output ARRAYREF of SCALAR (diagnostic messages) =head3 FORMAL SPECIFICATION [Validate] score : Score --------- forall s : staves @ valid_staff(s) (placeholder) =cut | |||||
| 337 | ||||||
| 338 | sub validate { | |||||
| 339 | 9 | 109 | my $self = $_[0]; | |||
| 340 | ||||||
| 341 | # Strategy: iterate staves; for each staff check that: | |||||
| 342 | # - event list is non-empty | |||||
| 343 | # - all Bar events divide time correctly per time signature | |||||
| 344 | # - all Tie/Slur events have matching start/stop pairs | |||||
| 345 | # Return all accumulated diagnostics rather than croaking on first failure. | |||||
| 346 | ||||||
| 347 | 9 | 7 | my @diagnostics; | |||
| 348 | ||||||
| 349 | 9 | 14 | if ($self->staff_count == 0) { | |||
| 350 | 4 | 6 | push @diagnostics, _fmt_msg('error_no_staves'); | |||
| 351 | 4 | 12 | return \@diagnostics; | |||
| 352 | } | |||||
| 353 | ||||||
| 354 | 5 5 | 5 8 | for my $staff (@{ $self->{_staves} }) { | |||
| 355 | 10 | 20 | my $sname = $staff->name // '(unnamed)'; | |||
| 356 | ||||||
| 357 | 10 | 21 | if ($staff->event_count == 0) { | |||
| 358 | 1 | 2 | push @diagnostics, _fmt_msg('warn_empty_staff', $sname); | |||
| 359 | 1 | 3 | next; | |||
| 360 | } | |||||
| 361 | ||||||
| 362 | 9 | 6 | my %pending_tie; # pos_key => 1 for ties awaiting a stop | |||
| 363 | 9 | 8 | my $in_slur = 0; # 1 while inside an unclosed slur arc | |||
| 364 | 9 | 10 | my $bar_num = 1; | |||
| 365 | 9 | 9 | my ($acc_n, $acc_d) = (0, 1); # accumulated bar duration as a rational | |||
| 366 | ||||||
| 367 | 9 | 13 | my $ts = $staff->initial_timesig // {}; | |||
| 368 | 9 | 12 | my ($exp_n, $exp_d) = _ts_to_rational($ts); | |||
| 369 | ||||||
| 370 | 9 9 | 6 15 | for my $ev (@{ $staff->events }) { | |||
| 371 | 6992 | 3517 | my $type = $ev->type; | |||
| 372 | 6992 | 2225 | my $d = $ev->data // {}; | |||
| 373 | ||||||
| 374 | 6992 | 2348 | if ($type eq 'TimeSig') { | |||
| 375 | 80 | 24 | ($exp_n, $exp_d) = _ts_to_rational($d); | |||
| 376 | 80 | 40 | next; | |||
| 377 | } | |||||
| 378 | ||||||
| 379 | 6912 | 2288 | if ($type eq 'Bar') { | |||
| 380 | 1556 | 538 | if ($acc_n > 0 && $exp_n > 0) { | |||
| 381 | 0 | 0 | my ($cn, $cd) = _rat_reduce($acc_n, $acc_d); | |||
| 382 | 0 | 0 | my ($en, $ed) = _rat_reduce($exp_n, $exp_d); | |||
| 383 | 0 | 0 | push @diagnostics, _fmt_msg( | |||
| 384 | 'warn_bar_duration', $sname, $bar_num, | |||||
| 385 | "$cn/$cd", "$en/$ed", | |||||
| 386 | ) unless $cn * $ed == $en * $cd; | |||||
| 387 | } | |||||
| 388 | 1556 | 358 | $bar_num++; | |||
| 389 | 1556 | 433 | ($acc_n, $acc_d) = (0, 1); | |||
| 390 | 1556 | 618 | next; | |||
| 391 | } | |||||
| 392 | ||||||
| 393 | 5356 | 2398 | next unless $type eq 'Note' || $type eq 'Chord' || $type eq 'Rest'; | |||
| 394 | ||||||
| 395 | # Accumulate duration (grace notes contribute nothing) | |||||
| 396 | 5218 | 3331 | unless ($d->{is_grace}) { | |||
| 397 | 5218 5218 | 1175 3095 | my ($dn, $dd) = @{ $d->{duration} // [0, 1] }; | |||
| 398 | 5218 | 2001 | ($acc_n, $acc_d) = _rat_reduce( | |||
| 399 | $acc_n * $dd + $dn * $acc_d, | |||||
| 400 | $acc_d * $dd, | |||||
| 401 | ); | |||||
| 402 | } | |||||
| 403 | ||||||
| 404 | # Tie tracking (rests cannot be tied) | |||||
| 405 | 5218 | 1759 | unless ($type eq 'Rest') { | |||
| 406 | my @pos_strs = $type eq 'Chord' | |||||
| 407 | 859 | 895 | ? @{ $d->{nwc_positions} // [] } | |||
| 408 | 4409 | 2928 | : ($d->{nwc_pos} // '0'); | |||
| 409 | 4409 | 1109 | for my $ps (@pos_strs) { | |||
| 410 | 5597 | 1597 | (my $pk = $ps) =~ s/\^\z//; | |||
| 411 | 5597 | 1358 | delete $pending_tie{$pk}; # consume any pending stop | |||
| 412 | 5597 | 2316 | $pending_tie{$pk} = 1 if $ps =~ /\^\z/; | |||
| 413 | } | |||||
| 414 | } | |||||
| 415 | ||||||
| 416 | # Slur tracking (rests are transparent to slur arcs) | |||||
| 417 | 5218 | 1875 | next if $type eq 'Rest'; | |||
| 418 | 4409 4409 4409 | 1495 2474 3995 | $in_slur = any { $_ eq 'Slur' } @{ $d->{articulations} // [] } ? 1 : 0; | |||
| 419 | } | |||||
| 420 | ||||||
| 421 | 9 | 17 | for my $pk (sort keys %pending_tie) { | |||
| 422 | 2 | 9 | push @diagnostics, _fmt_msg('warn_unmatched_tie', $sname, $pk); | |||
| 423 | } | |||||
| 424 | 9 | 19 | push @diagnostics, _fmt_msg('warn_unclosed_slur', $sname) if $in_slur; | |||
| 425 | } | |||||
| 426 | ||||||
| 427 | 5 | 9 | return \@diagnostics; | |||
| 428 | } | |||||
| 429 | ||||||
| 430 | # --------------------------------------------------------------------------- | |||||
| 431 | # Private | |||||
| 432 | # --------------------------------------------------------------------------- | |||||
| 433 | ||||||
| 434 | sub _fmt_msg { | |||||
| 435 | 21 | 16 | my ($key, @args) = @_; | |||
| 436 | 21 | 34 | croak "Unknown message key: $key" unless exists $MESSAGES{$key}; | |||
| 437 | 21 | 71 | return sprintf $MESSAGES{$key}, @args; | |||
| 438 | } | |||||
| 439 | ||||||
| 440 | # Convert a timesig hashref {beats, beat_type} to a rational [n, d] in quarter-note units. | |||||
| 441 | # Returns (0, 1) when the timesig is absent or incomplete. | |||||
| 442 | sub _ts_to_rational { | |||||
| 443 | 89 | 30 | my ($ts) = @_; | |||
| 444 | 89 | 131 | return (0, 1) unless ref $ts eq 'HASH' && $ts->{beats} && $ts->{beat_type}; | |||
| 445 | 88 | 33 | return _rat_reduce($ts->{beats} * 4, $ts->{beat_type}); | |||
| 446 | } | |||||
| 447 | ||||||
| 448 | # Reduce a fraction to lowest terms. Returns ($n, $d) with $d > 0. | |||||
| 449 | sub _rat_reduce { | |||||
| 450 | 5306 | 1403 | my ($n, $d) = @_; | |||
| 451 | 5306 | 2085 | return (0, 1) unless $n; | |||
| 452 | 88 | 41 | my $g = _gcd(abs($n), abs($d)); | |||
| 453 | 88 | 43 | return ($n / $g, $d / $g); | |||
| 454 | } | |||||
| 455 | ||||||
| 456 | sub _gcd { | |||||
| 457 | 88 | 18 | my ($a, $b) = @_; | |||
| 458 | 88 | 48 | ($a, $b) = ($b, $a % $b) while $b; | |||
| 459 | 88 | 36 | return $a; | |||
| 460 | } | |||||
| 461 | ||||||
| 462 | 1; | |||||
| 463 | ||||||