File Coverage

File:	blib/lib/Music/NWC2MusicXML/MusicXML.pm
Coverage:	82.8%

line	stmt	bran	cond	sub	time	code
1						package Music::NWC2MusicXML::MusicXML;
2
3	13 13 13			13	28344 7 86	use strict;
4	13 13 13			13	11 6 209	use warnings;
5	13 13 13			13	88 3534 34	use autodie qw(:all);
6
7						our $VERSION = '0.001.1';
8
9	13 13 13			13	20623 9 216	use Carp qw(croak carp);
10	13 13 13			13	27 5 28	use POSIX qw(floor);
11	13 13 13			13	333 1004 128	use Readonly;
12	13 13 13			13	13 7 164	use List::Util qw(any);
13	13 13 13			13	11 6 121	use Scalar::Util qw(blessed);
14	13 13 13			13	204 11248 116	use Params::Validate::Strict qw(validate_strict);
15	13 13 13			13	135 2079 104	use Params::Get;
16	13 13 13			13	115 7 81	use Music::NWC2MusicXML::Score;
17	13 13 13			13	9 5 37249	use Music::NWC2MusicXML::Event;
18
19						# ---------------------------------------------------------------------------
20						# MusicXML structural constants
21						# ---------------------------------------------------------------------------
22
23						# MusicXML version targeted (supported by MuseScore 3+)
24						Readonly::Scalar my $MUSICXML_VERSION => '4.0';
25
26						# DOCTYPE public/system identifiers
27						Readonly::Scalar my $DOCTYPE_PUBLIC =>
28						'-//Recordare//DTD MusicXML 4.0 Partwise//EN';
29						Readonly::Scalar my $DOCTYPE_SYSTEM =>
30						'http://www.musicxml.org/dtds/partwise.dtd';
31
32						# Default divisions per quarter note used as a fallback; the actual value is
33						# computed per-score from the LCM of all note-duration denominators.
34						Readonly::Scalar my $DEFAULT_DIVISIONS => 24;
35
36						# Maximum number of simultaneous open slurs per staff
37						Readonly::Scalar my $MAX_SLUR_NUMBER => 6;
38
39						# ---------------------------------------------------------------------------
40						# Clef mappings: NWC clef name -> { sign, line, [clef-octave-change] }
41						# ---------------------------------------------------------------------------
42						Readonly::Hash my %CLEF_MAP => (
43						Treble => { sign => 'G', line => 2 },
44						Bass => { sign => 'F', line => 4 },
45						Alto => { sign => 'C', line => 3 },
46						Tenor => { sign => 'C', line => 4 },
47						Percussion => { sign => 'percussion' },
48						Tab => { sign => 'TAB' },
49						);
50
51						# ---------------------------------------------------------------------------
52						# Articulation mappings: NWC token (initial-cap) -> { element, group }
53						# group: 'articulations' \| 'ornaments' \| 'direct' (emitted directly in <notations>)
54						Readonly::Hash my %ARTICULATION_MAP => (
55						Tenuto => { element => 'tenuto', group => 'articulations' },
56						Staccato => { element => 'staccato', group => 'articulations' },
57						Accent => { element => 'accent', group => 'articulations' },
58						Marcato => { element => 'strong-accent', group => 'articulations' },
59						Staccatissimo => { element => 'staccatissimo', group => 'articulations' },
60						Fermata => { element => 'fermata', group => 'direct' },
61						Trill => { element => 'trill-mark', group => 'ornaments' },
62						Mordent => { element => 'mordent', group => 'ornaments' },
63						Turn => { element => 'turn', group => 'ornaments' },
64						);
65
66						# ---------------------------------------------------------------------------
67						# Dynamic markings: NWC -> MusicXML element
68						# ---------------------------------------------------------------------------
69						Readonly::Hash my %DYNAMIC_MAP => map { $_ => $_ }
70						qw(pppp ppp pp p mp mf f ff fff ffff);
71
72						# ---------------------------------------------------------------------------
73						# Tempo base unit: NWC Base field -> { unit, dot, quarter_factor }
74						# quarter_factor converts noted BPM to quarter-note BPM for <sound tempo="..."/>
75						# ---------------------------------------------------------------------------
76						Readonly::Hash my %TEMPO_BASE_MAP => (
77						'Whole' => { unit => 'whole', dot => 0, factor => 4 },
78						'Half' => { unit => 'half', dot => 0, factor => 2 },
79						'Quarter' => { unit => 'quarter', dot => 0, factor => 1 },
80						'Eighth' => { unit => 'eighth', dot => 0, factor => 0.5 },
81						'Sixteenth' => { unit => '16th', dot => 0, factor => 0.25 },
82						'Dotted Whole' => { unit => 'whole', dot => 1, factor => 6 },
83						'Dotted Half' => { unit => 'half', dot => 1, factor => 3 },
84						'Dotted Quarter' => { unit => 'quarter', dot => 1, factor => 1.5 },
85						'Dotted Eighth' => { unit => 'eighth', dot => 1, factor => 0.75 },
86						'Dotted Sixteenth' => { unit => '16th', dot => 1, factor => 0.375 },
87						);
88
89						# ---------------------------------------------------------------------------
90						# Pitch-conversion constants
91						# ---------------------------------------------------------------------------
92
93						# Reference note (step_index, octave) for NWC position 0 = middle line (3rd from bottom) of each staff.
94						# Step indices: C=0, D=1, E=2, F=3, G=4, A=5, B=6
95						# Verified against Pilgrim.nwc: Bass pos -7 = A2 (A-drone), Treble pos -9 = D4 (tonic).
96						Readonly::Hash my %CLEF_REF => (
97						Treble => [ 6, 4 ], # B4 (middle line)
98						Bass => [ 1, 3 ], # D3 (middle line)
99						Alto => [ 0, 4 ], # C4 (middle line)
100						Tenor => [ 5, 3 ], # A3 (middle line)
101						Percussion => [ 6, 4 ], # B4 (treat as treble)
102						Tab => [ 6, 4 ], # B4 (treat as treble)
103						);
104
105						# Diatonic step names indexed 0-6
106						Readonly::Array my @STEP_NAMES => qw(C D E F G A B);
107
108						# Circle-of-fifths order: sharps = F C G D A E B; flats = B E A D G C F
109						Readonly::Array my @SHARP_STEPS => ( 3, 0, 4, 1, 5, 2, 6 );
110						Readonly::Array my @FLAT_STEPS => ( 6, 2, 5, 1, 4, 0, 3 );
111
112						# NWC accidental prefix -> [ semitone_alter, MusicXML accidental name ]
113						# P1: empty prefix and unknown prefixes fall back to key-signature alter (no accidental element).
114						# P2: 'x' is NWC's alias for '##' (double-sharp written as a cross).
115						Readonly::Hash my %ACCIDENTAL_MAP => (
116						'#' => [ 1, 'sharp' ],
117						'##' => [ 2, 'double-sharp' ],
118						'x' => [ 2, 'double-sharp' ],
119						'b' => [ -1, 'flat' ],
120						'bb' => [ -2, 'double-flat' ],
121						'n' => [ 0, 'natural' ],
122						);
123
124						# NWC base-duration name -> MusicXML type string
125						Readonly::Hash my %NWC_TYPE_MAP => (
126						Whole => 'whole',
127						Half => 'half',
128						'4th' => 'quarter',
129						'8th' => 'eighth',
130						'16th' => '16th',
131						'32nd' => '32nd',
132						'64th' => '64th',
133						);
134
135						# Flow-control directive -> MusicXML element and/or words direction
136						Readonly::Hash my %FLOW_CONTROL_MAP => (
137						Coda => { element => 'coda' },
138						Segno => { element => 'segno' },
139						DaCapo => { words => 'D.C.' },
140						DaCapoAlFine => { words => 'D.C. al Fine' },
141						DaCapoAlCoda => { words => 'D.C. al Coda' },
142						DalSegno => { words => 'D.S.' },
143						DalSegnoAlFine => { words => 'D.S. al Fine' },
144						DalSegnoAlCoda => { words => 'D.S. al Coda' },
145						Fine => { words => 'Fine' },
146						ToCoda => { element => 'coda', words => 'To Coda' },
147						);
148
149						Readonly::Hash my %MESSAGES => (
150						error_bad_score => 'generate: argument must be a Music::NWC2MusicXML::Score',
151						error_no_staves => 'Score contains no staves -- cannot generate MusicXML',
152						error_write_failed => 'Cannot write to output: %s',
153						error_internal => 'Internal error: %s',
154						warn_unknown_clef => 'Unrecognised NWC clef %s -- defaulting to Treble',
155						warn_unknown_dynamic => 'Unrecognised dynamic marking %s',
156						warn_unsupported_art => 'Unsupported articulation %s',
157						warn_approx_bar => 'Bar style %s approximated as regular',
158						);
159
160 - 398						=head1 NAME Music::NWC2MusicXML::MusicXML - Convert an internal Score object to a MusicXML 4.0 document string. =head1 VERSION 0.001.1 =head1 SYNOPSIS # --- Pattern 1: full pipeline from a .nwc file --- use Music::NWC2MusicXML::NWC; use Music::NWC2MusicXML::Parser; use Music::NWC2MusicXML::MusicXML; my $nwctxt = Music::NWC2MusicXML::NWC->read('my_score.nwc'); my $score = Music::NWC2MusicXML::Parser->new->parse($nwctxt); my $xml = Music::NWC2MusicXML::MusicXML->new->generate($score); # Write raw bytes -- the string is already pure ASCII (numeric entities # for any non-ASCII source characters). open my $fh, '>:raw', 'output.musicxml' or die $!; print $fh $xml; close $fh; # --- Pattern 2: custom indentation --- my $gen = Music::NWC2MusicXML::MusicXML->new(indent => "\t"); my $xml = $gen->generate($score); # --- Pattern 3: validate the output with an external tool --- # (run in the shell after writing the file) # xmllint --noout output.musicxml # --- Pattern 4: generate and keep in memory for further processing --- my $xml_string = Music::NWC2MusicXML::MusicXML->new->generate($score); my @lines = split /\n/, $xml_string; my ($part_list) = grep { /part-list/ } @lines; =head1 DESCRIPTION C<Music::NWC2MusicXML::MusicXML> is the last stage of the NWC-to-MusicXML pipeline. It takes a C<Music::NWC2MusicXML::Score> object -- the internal representation built by C<Music::NWC2MusicXML::Parser> -- and returns a self-contained MusicXML 4.0 document as a plain string. The generator knows nothing about the NWCTXT or NWC binary format. Every musical decision (pitches, durations, articulations, dynamics, tempo, key, clef, copyright text) was already made by the parser. The generator only serialises the Score object tree into valid XML. =head2 Divisions MusicXML requires one integer, C<< <divisions> >>, that says how many ticks equal one quarter note. To represent every note duration exactly -- including unusual tuplet values -- the generator scans all note durations across all staves, collects the denominators of their rational representations, and computes their least common multiple (LCM). That LCM becomes C<< <divisions> >>. No duration is ever rounded or truncated. =head2 Page layout and credits The generator emits a C<< <defaults> >> block that records the actual page size and margin values expressed in MusicXML tenths. Without this block a renderer cannot interpret the absolute coordinate values used by credit elements, so title and copyright placement would be undefined. Page dimensions default to A4 (210 x 297 mm) with 1.27 cm margins, which match NWC's own defaults. If the source NWC file contained a C<PgMargins> record the parser stores the margin values in the Score's C<page_setup> hashref and the generator reads them from there. Each title, subtitle, and copyright line is emitted as its own separate C<< <credit> >> element: =over 4 =item * Title -- C<< <credit page="1"> >>; large font; centred near the top of page 1. =item * Subtitle (the NWC Author field) -- C<< <credit page="1"> >>; medium font; centred directly below the title. =item * Each copyright line -- C<< <credit> >> with B<no page attribute>; this instructs conforming renderers to display the line on B<every> page. One separate C<< <credit> >> element is used per line; putting multiple C<< <credit-words> >> inside a single C<< <credit> >> causes many renderers to display only the last one. =back =head2 Articulations NWC encodes articulations as initial-capital tokens in the C<Dur:> field (for example C<Tenuto>, C<Staccato>, C<Accent>). The generator groups them into the correct MusicXML wrapper: =over 4 =item * C<< <articulations> >> -- tenuto, staccato, accent, strong-accent, staccatissimo. =item * C<< <ornaments> >> -- trill-mark, mordent, turn. =item * Direct child of C<< <notations> >> -- fermata. =back The C<Slur> token is never emitted as an articulation; it is handled by the slur-annotation pre-pass (see L</Slurs and ties> below). =head2 Slurs and ties A single pre-pass over all events in a staff (C<_annotate_events>) detects slur arcs and tie pairs before the events are grouped into measures. This means arcs that cross a bar line are handled correctly. Each event is annotated with flags that the measure emitter reads when writing C<< <slur> >> and C<< <tied> >> elements. Tie detection uses the raw NWC position string as a key. A C<^> suffix on a position string (e.g. C<Pos:-7^>) means the note is tied forward; the generator strips the suffix to match the tied-to note. =head2 Hairpins (wedges) NWC does not use standalone records for in-staff hairpins. Instead it attaches C<Opts:Crescendo> or C<Opts:Diminuendo> to every note and rest that sits under the arc. A second pre-pass (C<_annotate_wedges>) detects the start and end of each arc by watching for transitions: the first event carrying a hairpin flag starts the arc; the first event that drops the flag closes it. The wedge stop is emitted as a C<crescOff> direction immediately after the last note of the arc. =head2 Tempo variance Markings such as C<Accelerando>, C<Ritardando>, C<Rallentando>, and C<RitardandoToTempo> (rendered as "a tempo") are stored as C<TempoVariance> events by the parser. The generator converts them to italic C<< <words> >> direction elements using the C<%TEMPO_VARIANCE_TEXT> table. =head2 Part name resolution Display names for each staff are resolved in three steps: =over 4 =item 1. Use the NWC staff name, if it is not a generic default such as C<Staff> or C<Staff-2>. =item 2. Fall back to the MIDI instrument name. =item 3. Fall back to the positional name C<Staff-N> (1-based). =back After all candidates are found, any name that appears on more than one staff is replaced with C<Staff-N> to guarantee unique C<< <part-name> >> values. =head1 COMMON PITFALLS =over 4 =item B<Opening the output file in text mode> The output string is pure ASCII (all non-ASCII characters are escaped as numeric XML entities). Opening the output file with C<< '>:encoding(UTF-8)' >> is harmless but unnecessary; opening it with C<< '>:encoding(Latin-1)' >> or a similar 8-bit encoding and then printing a string that contains non-ASCII bytes would corrupt the file. The safest choice is C<< '>:raw' >>. =item B<Multiple copyright lines in one credit element> If you call C<_emit_credits> and place two C<< <credit-words> >> children inside a single C<< <credit> >> element, most renderers (including MuseScore and Finale) display only the B<last> C<< <credit-words> >> and silently discard the rest. This module uses one C<< <credit> >> per copyright line to avoid this. =item B<Missing defaults section> The absolute coordinates in C<< <credit> >> elements (C<default-x>, C<default-y>) are measured in MusicXML "tenths" from the bottom-left corner of the page. They are meaningless to a renderer unless a C<< <defaults> >> block defines the page size and the tenths-per-mm scaling factor. This module always emits C<< <defaults> >> before any C<< <credit> >> elements. =item B<Two separate rights elements in identification> C<< <identification> >> accepts only one C<< <rights> >> child in practice; a second one shadows the first. This module joins multiple copyright lines with a newline character inside a single C<< <rights> >> element. =item B<Slur token treated as an articulation> NWC encodes slurs as C<Slur> in the same token list as articulations. Do not add C<Slur> to C<%ARTICULATION_MAP>; the slur-annotation pre-pass handles it. If C<Slur> were also emitted as an articulation element the output XML would be invalid. =item B<Score with no staves> Calling C<generate> on a C<Score> object that has no staves will C<croak> immediately. Always check that the parser produced at least one staff before calling the generator. =back =head1 ENCODING =over 4 =item B<Input (Score metadata fields)> Metadata strings (Title, Author, Copyright1, Copyright2, etc.) may contain any Unicode characters, including non-ASCII letters, accented characters, and the copyright symbol (U+00A9). The NWC binary decoder may deliver these as Latin-1 bytes; once stored in Perl scalars they are handled correctly as long as they pass through C<_xml_escape> before being written to the output. =item B<Output (the generated XML string)> The string returned by C<generate> is B<pure 7-bit ASCII>. Every character whose code point is above 127 is converted to a numeric XML character reference (C<&#N;>), for example C<©> for the copyright symbol. The XML declaration at the top of the document reads C<encoding="UTF-8">, which remains correct because numeric character references are valid in any XML encoding. =item B<Emojis and full Unicode> Emoji and supplementary-plane characters (code points above U+FFFF) are not tested but will be escaped correctly by C<_xml_escape> as long as Perl has decoded them to proper Unicode code points (i.e. C<utf8::decode> has been applied or the string was read with a C<:utf8> layer). Raw multi-byte UTF-8 bytes that have B<not> been decoded will be escaped byte-by-byte and will produce incorrect numeric references. =back =cut
399
400						# ---------------------------------------------------------------------------
401						# new
402						# ---------------------------------------------------------------------------
403
404 - 464						=head2 new Create a new generator object. =head3 Purpose Factory constructor. Creates a configured generator ready to call C<generate> one or more times. The same generator instance can be used to process multiple Score objects; each C<generate> call is independent. =head3 Arguments All arguments are named (passed as a flat key/value list) and optional. =over 4 =item C<indent> The string used for one level of XML indentation. Defaults to two spaces. Pass C<"\t"> for tab indentation. Only affects whitespace; the XML content is identical regardless of the indent setting. =item C<diagnostics> A C<Music::NWC2MusicXML::Diagnostics> instance for routing warning messages. When omitted, warnings are sent directly to C<carp>. =back =head3 Returns A blessed C<Music::NWC2MusicXML::MusicXML> object. =head3 Side Effects None. =head3 Usage Example # Default (two-space indent) my $gen = Music::NWC2MusicXML::MusicXML->new; # Tab indent my $gen = Music::NWC2MusicXML::MusicXML->new(indent => "\t"); =head3 API SPECIFICATION =head4 Input indent : SCALAR (optional, default ' ') diagnostics : OBJECT Music::NWC2MusicXML::Diagnostics (optional) =head4 Output Music::NWC2MusicXML::MusicXML object =head3 MESSAGES This method does not emit any diagnostic messages. =cut
465
466						sub new {
467	231			231	405577	my ($class, %input) = @_;
468	231				511	my $args = validate_strict(
469						schema => {
470						diagnostics => { type => 'object', optional => 1 },
471						indent => { type => 'scalar', optional => 1, default => ' ' },
472						},
473						input => \%input,
474						);
475	231	50			8711	croak $@ unless defined $args;
476
477						my $self = bless {
478						_diagnostics => $args->{diagnostics},
479						_indent => $args->{indent},
480	231				345	}, $class;
481
482	231				455	return $self;
483						}
484
485						# ---------------------------------------------------------------------------
486						# Public: generate
487						# ---------------------------------------------------------------------------
488
489 - 594						=head2 generate Convert a C<Music::NWC2MusicXML::Score> object to a MusicXML 4.0 document and return the complete document as a string. =head3 Purpose Top-level entry point. Orchestrates, in order: =over 4 =item 1. XML declaration and DOCTYPE header. =item 2. Page layout geometry (C<< <defaults> >>). =item 3. Work title (C<< <work> >>). =item 4. Identification metadata: composer, lyricist, rights (C<< <identification> >>). =item 5. Visual credits: title, subtitle, and copyright lines (C<< <credit> >> elements). =item 6. Part list: one C<< <score-part> >> per staff (C<< <part-list> >>). =item 7. Musical content: one C<< <part> >> per staff, each containing numbered measures with notes, rests, dynamics, tempo, articulations, slurs, ties, and wedge hairpins. =back Each staff is processed by a two-stage pipeline: =over 4 =item Stage 1 -- annotation pre-passes. C<_annotate_events> detects slur arcs and tie pairs across the entire staff before measure grouping. C<_annotate_wedges> detects hairpin (crescendo / diminuendo) arcs stored as per-note C<Opts:> flags. Both passes store their results in a shared C<%ann> hash keyed by stringified event reference. =item Stage 2 -- measure emission. Events are gathered into measure-sized groups separated by C<Bar> events. For each measure, C<_emit_measure> serialises notes, rests, directions, and mid-staff attribute changes, consulting C<%ann> for slur, tie, and wedge annotations. =back =head3 Arguments =over 4 =item C<$score> A C<Music::NWC2MusicXML::Score> object (required). Must contain at least one staff; otherwise the method croaks. =back =head3 Returns A scalar string holding the complete MusicXML 4.0 document. The string is pure 7-bit ASCII: all non-ASCII source characters are replaced with numeric XML character references (C<&#N;>). The XML declaration at the top of the string declares C<encoding="UTF-8">, which is correct. The string ends with a single newline character. =head3 Side Effects May issue warnings via C<carp> for unsupported or unrecognised values (unknown clef, unknown dynamic marking, unsupported articulation token, approximate barline style). =head3 Usage Example my $xml = $gen->generate($score); # Write to a file -- ':raw' is sufficient; the string is pure ASCII. open my $fh, '>:raw', 'out.musicxml' or die $!; print $fh $xml; close $fh; =head3 API SPECIFICATION =head4 Input $score : Music::NWC2MusicXML::Score (required, must have staff_count > 0) =head4 Output SCALAR -- complete MusicXML 4.0 document, pure 7-bit ASCII, newline-terminated =head3 MESSAGES \| Code \| Meaning \| Resolution \| \|---------------------\|------------------------------------------\|---------------------------------\| \| error_bad_score \| Argument is not a Score object \| Pass the object returned by Parser \| \| error_no_staves \| Score has zero staves \| Confirm the parser found AddStaff records \| \| warn_unknown_clef \| NWC clef name not in CLEF_MAP \| Treble used as fallback \| \| warn_unknown_dynamic\| Dynamic marking not in DYNAMIC_MAP \| Direction element omitted \| \| warn_unsupported_art\| Articulation token not in ARTICULATION_MAP\| Mark omitted; warning issued \| \| warn_approx_bar \| Barline style has no direct MusicXML map \| Regular barline used \| =cut
595
596						sub generate {
597	197			197	577	my ($self, $score) = @_;
598
599	197	100	100		530	croak _fmt_msg('error_bad_score')
600						unless blessed($score) && $score->isa('Music::NWC2MusicXML::Score');
601
602	186	100			233	croak _fmt_msg('error_no_staves')
603						unless $score->staff_count > 0;
604
605						# Calculate the divisions value from all note durations in the score.
606	181				261	my $divisions = $self->_calculate_divisions($score);
607
608	181				99	my @out;
609
610	181				116	push @out, '<?xml version="1.0" encoding="UTF-8"?>';
611	181				167	push @out, sprintf('<!DOCTYPE score-partwise PUBLIC "%s" "%s">',
612						$DOCTYPE_PUBLIC, $DOCTYPE_SYSTEM);
613	181				124	push @out, sprintf('<score-partwise version="%s">', $MUSICXML_VERSION);
614
615	181		50		209	my $layout = _compute_page_layout($score->page_setup // {});
616
617	181				184	push @out, $self->_emit_work($score->metadata);
618	181				143	push @out, $self->_emit_identification($score->metadata);
619	181				246	push @out, $self->_emit_defaults($layout, $score->fonts);
620	181				184	push @out, $self->_emit_credits($score->metadata, $layout);
621	181				175	push @out, $self->_emit_part_list($score->staves);
622	181				213	push @out, $self->_emit_parts($score->staves, $divisions);
623
624	181				23365	push @out, '</score-partwise>';
625
626	181				133883	return join("\n", @out) . "\n";
627						}
628
629						# ---------------------------------------------------------------------------
630						# Private: page layout constants and helpers
631						# ---------------------------------------------------------------------------
632
633						# Standard MusicXML scaling: 40 tenths per staff space, 7.2175 mm per space.
634						Readonly::Scalar my $MM_PER_SPACE => 7.2175;
635						Readonly::Scalar my $TENTHS_PER_SPACE => 40;
636						Readonly::Scalar my $TENTHS_PER_MM => $TENTHS_PER_SPACE / $MM_PER_SPACE;
637
638						# Default to A4 paper (210 x 297 mm); most common in international music publishing.
639						Readonly::Scalar my $DEFAULT_PAGE_W_MM => 210.0;
640						Readonly::Scalar my $DEFAULT_PAGE_H_MM => 297.0;
641						Readonly::Scalar my $DEFAULT_MARGIN_CM => 1.27; # standard NWC default
642
643						# Derive page geometry in tenths from PgSetup/PgMargins fields (cm margins).
644						# Returns a hashref: page_height, page_width, margin_l, margin_r, margin_t,
645						# margin_b, center_x, right_x.
646						sub _compute_page_layout {
647	184			184	2054	my ($ps) = @_;
648	184		50		148	$ps //= {};
649
650						# Margins: NWC stores them in cm (Left/Top/Right/Bottom from PgMargins).
651						# When a side is absent, fall back to Left, then the hardcoded default.
652	184		67		255	my $left = $ps->{Left} // $DEFAULT_MARGIN_CM;
653	184		67		230	my $right = $ps->{Right} // $left;
654	184		67		235	my $top = $ps->{Top} // $left;
655	184		67		354	my $bottom = $ps->{Bottom} // $left;
656
657	184				309	my $margin_l = $left * 10 * $TENTHS_PER_MM;
658	184				103	my $margin_r = $right * 10 * $TENTHS_PER_MM;
659	184				68	my $margin_t = $top * 10 * $TENTHS_PER_MM;
660	184				122	my $margin_b = $bottom * 10 * $TENTHS_PER_MM;
661
662	184				77	my $page_h = $DEFAULT_PAGE_H_MM * $TENTHS_PER_MM;
663	184				101	my $page_w = $DEFAULT_PAGE_W_MM * $TENTHS_PER_MM;
664
665						return {
666	184				486	page_height => $page_h,
667						page_width => $page_w,
668						margin_l => $margin_l,
669						margin_r => $margin_r,
670						margin_t => $margin_t,
671						margin_b => $margin_b,
672						center_x => $page_w / 2,
673						right_x => $page_w - $margin_r,
674						};
675						}
676
677						sub _emit_defaults {
678	181			181	146	my ($self, $layout, $fonts) = @_;
679	181		50		126	$fonts //= [];
680	181				87	my @out;
681	181				109	my $i = $self->{_indent};
682
683	181				727	my $ph = sprintf '%.2f', $layout->{page_height};
684	181				172	my $pw = sprintf '%.2f', $layout->{page_width};
685	181				158	my $ml = sprintf '%.2f', $layout->{margin_l};
686	181				167	my $mr = sprintf '%.2f', $layout->{margin_r};
687	181				112	my $mt = sprintf '%.2f', $layout->{margin_t};
688	181				120	my $mb = sprintf '%.2f', $layout->{margin_b};
689
690	181				79	push @out, '<defaults>';
691	181				115	push @out, "${i}<scaling>";
692	181				269	push @out, "${i}${i}<millimeters>$MM_PER_SPACE</millimeters>";
693	181				170	push @out, "${i}${i}<tenths>$TENTHS_PER_SPACE</tenths>";
694	181				112	push @out, "${i}</scaling>";
695	181				95	push @out, "${i}<page-layout>";
696	181				95	push @out, "${i}${i}<page-height>$ph</page-height>";
697	181				105	push @out, "${i}${i}<page-width>$pw</page-width>";
698	181				98	push @out, "${i}${i}<page-margins type=\"both\">";
699	181				110	push @out, "${i}${i}${i}<left-margin>$ml</left-margin>";
700	181				128	push @out, "${i}${i}${i}<right-margin>$mr</right-margin>";
701	181				105	push @out, "${i}${i}${i}<top-margin>$mt</top-margin>";
702	181				118	push @out, "${i}${i}${i}<bottom-margin>$mb</bottom-margin>";
703	181				106	push @out, "${i}${i}</page-margins>";
704	181				80	push @out, "${i}</page-layout>";
705
706						# Font declarations from NWC Font records (word-font then lyric-font per schema order)
707	181				97	my ($word_font, $lyric_font);
708	181				119	for my $font (@$fonts) {
709	349	50	50		383	next unless length($font->{typeface} // '');
710	349		50		240	my $style = $font->{style} // '';
711	349	100 100	100 67		403	if ($style eq 'StaffLyric' && !defined $lyric_font) {
712	30				21	$lyric_font = $font;
713						} elsif ($style =~ /\AStaff/i && !defined $word_font) {
714	29				24	$word_font = $font;
715						}
716						}
717	181				187	for my $pair ([$word_font, 'word-font'], [$lyric_font, 'lyric-font']) {
718	362				185	my ($font, $elem) = @$pair;
719	362	100			264	next unless defined $font;
720	59		50		45	my $tf = _xml_escape($font->{typeface} // '');
721	59	50			85	my $sz = $font->{size} ? " font-size=\"$font->{size}\"" : '';
722	59	100			44	my $wt = $font->{bold} ? ' font-weight="bold"' : '';
723	59	100			48	my $fst = $font->{italic} ? ' font-style="italic"' : '';
724	59				62	push @out, "${i}<$elem font-family=\"$tf\"${sz}${wt}${fst}/>";
725						}
726
727	181				130	push @out, '</defaults>';
728	181				368	return @out;
729						}
730
731						# ---------------------------------------------------------------------------
732						# Private: top-level sections
733						# ---------------------------------------------------------------------------
734
735						sub _emit_work {
736	181			181	129	my ($self, $meta) = @_;
737	181				86	my @out;
738	181				141	my $i = $self->{_indent};
739	181				103	push @out, '<work>';
740						push @out, "${i}<work-title>" . _xml_escape($meta->{Title} // '') . '</work-title>'
741	181	100	50		259	if $meta->{Title};
742	181				101	push @out, '</work>';
743	181				165	return @out;
744						}
745
746						sub _emit_identification {
747	181			181	116	my ($self, $meta) = @_;
748	181				70	my @out;
749	181				99	my $i = $self->{_indent};
750	181				132	push @out, '<identification>';
751						push @out, "${i}<creator type=\"composer\">"
752						. _xml_escape($meta->{Author} // '') . '</creator>'
753	181	100	50		332	if $meta->{Author};
754						push @out, "${i}<creator type=\"lyricist\">"
755						. _xml_escape($meta->{Lyricist} // '') . '</creator>'
756	181	50	0		141	if $meta->{Lyricist};
757						# Combine all copyright lines into one <rights> element; multiple <rights>
758						# elements cause renderers to discard all but the last.
759	181				85	my @cr_lines;
760	181	100 50	33 67		347	if (defined $meta->{Copyright1} \|\| defined $meta->{Copyright2}) {
761						push @cr_lines, $meta->{Copyright1}
762	47	50	33		145	if defined $meta->{Copyright1} && length $meta->{Copyright1};
763						push @cr_lines, $meta->{Copyright2}
764	47	100	67		103	if defined $meta->{Copyright2} && length $meta->{Copyright2};
765						} elsif (defined $meta->{Copyright} && length $meta->{Copyright}) {
766	0				0	push @cr_lines, $meta->{Copyright};
767						}
768	181	100			232	push @out, "${i}<rights>" . _xml_escape(join "\n", @cr_lines) . '</rights>'
769						if @cr_lines;
770	181				138	push @out, "${i}<encoding>";
771	181				159	push @out, "${i}${i}<software>Music::NWC2MusicXML $VERSION</software>";
772	181				112	push @out, "${i}</encoding>";
773	181	50	33 0		180	if (defined $meta->{Comments} && length($meta->{Comments} // '')) {
774	0				0	push @out, "${i}<miscellaneous>";
775						push @out, "${i}${i}<miscellaneous-field name=\"comments\">"
776	0				0	. _xml_escape($meta->{Comments}) . '</miscellaneous-field>';
777	0				0	push @out, "${i}</miscellaneous>";
778						}
779	181				100	push @out, '</identification>';
780	181				213	return @out;
781						}
782
783						sub _emit_credits {
784	181			181	123	my ($self, $meta, $layout) = @_;
785	181		33		108	$layout //= _compute_page_layout({});
786	181				83	my @out;
787	181				101	my $i = $self->{_indent};
788
789	181				170	my $cx = sprintf '%.2f', $layout->{center_x};
790	181				184	my $ty = sprintf '%.2f', $layout->{page_height} - $layout->{margin_t};
791	181				210	my $sy = sprintf '%.2f', $layout->{page_height} - $layout->{margin_t} - 60;
792	181				110	my $bot = $layout->{margin_b};
793
794						# Title credit on page 1 (large, centred near top)
795	181	100	67		221	if (defined $meta->{Title} && length $meta->{Title}) {
796	82				47	push @out, '<credit page="1">';
797	82				60	push @out, "${i}<credit-type>title</credit-type>";
798						push @out, "${i}<credit-words"
799						. " default-x=\"$cx\" default-y=\"$ty\""
800						. ' justify="center" valign="top"'
801						. ' font-size="24"'
802	82				123	. '>' . _xml_escape($meta->{Title}) . '</credit-words>';
803	82				57	push @out, '</credit>';
804						}
805
806						# Subtitle credit on page 1 (centred, just below title)
807	181	100	67		184	if (defined $meta->{Author} && length $meta->{Author}) {
808	42				28	push @out, '<credit page="1">';
809	42				28	push @out, "${i}<credit-type>subtitle</credit-type>";
810						push @out, "${i}<credit-words"
811						. " default-x=\"$cx\" default-y=\"$sy\""
812						. ' justify="center" valign="top"'
813						. ' font-size="14"'
814	42				63	. '>' . _xml_escape($meta->{Author}) . '</credit-words>';
815	42				24	push @out, '</credit>';
816						}
817
818						# Copyright lines: each gets its OWN <credit> element (no page attribute ->
819						# appears on every page). Multiple <credit-words> in one <credit> cause
820						# renderers to show only the last element.
821	181				95	my @cr_lines;
822	181	100 50	33 67		285	if (defined $meta->{Copyright1} \|\| defined $meta->{Copyright2}) {
823						push @cr_lines, $meta->{Copyright1}
824	47	50	33		83	if defined $meta->{Copyright1} && length $meta->{Copyright1};
825						push @cr_lines, $meta->{Copyright2}
826	47	100	67		74	if defined $meta->{Copyright2} && length $meta->{Copyright2};
827						} elsif (defined $meta->{Copyright} && length $meta->{Copyright}) {
828	0				0	push @cr_lines, $meta->{Copyright};
829						}
830
831						# Stack lines from bottom margin upward: last line at margin, each prior
832						# line 14 tenths higher.
833	181				90	my $line_step = 14;
834	181				109	my $n = scalar @cr_lines;
835	181				203	for my $idx (0 .. $#cr_lines) {
836	88				94	my $y = sprintf '%.2f', $bot + $line_step * ($n - 1 - $idx);
837	88				33	push @out, '<credit>';
838	88				52	push @out, "${i}<credit-type>rights</credit-type>";
839	88				72	push @out, "${i}<credit-words"
840						. " default-x=\"$cx\" default-y=\"$y\""
841						. ' justify="center" valign="bottom"'
842						. ' font-size="10"'
843						. '>' . _xml_escape($cr_lines[$idx]) . '</credit-words>';
844	88				65	push @out, '</credit>';
845						}
846
847	181				214	return @out;
848						}
849
850						sub _emit_part_list {
851	181			181	117	my ($self, $staves) = @_;
852	181				71	my @out;
853	181				93	my $i = $self->{_indent};
854
855	181				206	my @names = _resolve_part_names($staves);
856	181				137	my @groups = _compute_groups($staves);
857
858	181				97	push @out, '<part-list>';
859	181				82	my $part_id = 1;
860	181				120	for my $staff (@$staves) {
861	383				152	my $idx = $part_id - 1;
862
863						# Groups starting before this score-part (outer before inner)
864	383 29 232				238 66 205	for my $g (sort { $a->{num} <=> $b->{num} } grep { $_->{start} == $idx } @groups) {
865	58				50	push @out, "${i}<part-group type=\"start\" number=\"$g->{num}\">";
866	58				37	push @out, "${i}${i}<group-symbol>$g->{symbol}</group-symbol>";
867	58				40	push @out, "${i}${i}<group-barline>$g->{bars}</group-barline>";
868	58				41	push @out, "${i}</part-group>";
869						}
870
871	383				184	my $id = "P$part_id";
872	383				181	my $name = _xml_escape($names[$idx]);
873	383				236	push @out, "${i}<score-part id=\"$id\">";
874	383	100	50		283	my $print_attr = ($staff->{_visible} // 1) ? '' : ' print-object="no"';
875	383				221	push @out, "${i}${i}<part-name${print_attr}>$name</part-name>";
876	383				195	my $instr = $staff->instrument;
877	383	100	67		350	if ($instr && $instr->{name}) {
878	125				71	push @out, "${i}${i}<score-instrument id=\"${id}-I1\">";
879						push @out, "${i}${i}${i}<instrument-name>"
880	125				74	. _xml_escape($instr->{name}) . '</instrument-name>';
881	125				75	push @out, "${i}${i}</score-instrument>";
882	125	100			83	if (defined $instr->{patch}) {
883	124		100		78	my $chan = $staff->{_channel} // 1;
884	124				94	push @out, "${i}${i}<midi-instrument id=\"${id}-I1\">";
885	124				71	push @out, "${i}${i}${i}<midi-channel>$chan</midi-channel>";
886						push @out, "${i}${i}${i}<midi-program>"
887	124				128	. ($instr->{patch} + 1) . '</midi-program>';
888	124				79	push @out, "${i}${i}</midi-instrument>";
889						}
890						}
891	383				220	push @out, "${i}</score-part>";
892
893						# Groups stopping after this score-part (inner before outer)
894	383 29 232				193 25 112	for my $g (sort { $b->{num} <=> $a->{num} } grep { $_->{end} == $idx } @groups) {
895	58				37	push @out, "${i}<part-group type=\"stop\" number=\"$g->{num}\"/>";
896						}
897
898	383				168	$part_id++;
899						}
900	181				76	push @out, '</part-list>';
901	181				440	return @out;
902						}
903
904						# Compute bracket/brace grouping structure from WithNextStaff flags.
905						# Returns a list of group hashrefs: {num, start, end, symbol, bars}.
906						# Bracket groups are numbered before Brace groups so outer comes first.
907						sub _compute_groups {
908	181			181	110	my ($staves) = @_;
909	181				78	my @all_groups;
910	181				77	my $group_num = 1;
911
912	181				97	for my $sym (qw(Bracket Brace)) {
913	362				144	my $i = 0;
914	362				208	while ($i < @$staves) {
915	592		100		409	my $wnxs = $staves->[$i]{_with_next_staff} // '';
916	592 174				354 135	my %flags = map { $_ => 1 } split /,/, $wnxs;
917
918	592	100			275	if ($flags{$sym}) {
919	58				20	my $start = $i;
920	58	50			39	my $connect_bars = $flags{ConnectBars} ? 'yes' : 'no';
921						# Extend the group while consecutive staves carry the same flag.
922	58				48	while ($i < @$staves - 1) {
923	174		50		113	my $cur = $staves->[$i]{_with_next_staff} // '';
924	174 522				78 209	my %cf = map { $_ => 1 } split /,/, $cur;
925	174	50			90	last unless $cf{$sym};
926	174				102	$i++;
927						}
928	58	50			118	push @all_groups, {
929						num => $group_num++,
930						start => $start,
931						end => $i,
932						symbol => lc($sym),
933						bars => $connect_bars,
934						} if $i > $start;
935	58				56	$i++;
936						} else {
937	534				283	$i++;
938						}
939						}
940						}
941
942	181				104	return @all_groups;
943						}
944
945						# ---------------------------------------------------------------------------
946						# Private: part-name resolution
947						# ---------------------------------------------------------------------------
948
949						# Resolve a display name for every staff, applying a three-level priority:
950						# 1. The NWC staff name, if it is not a generic default.
951						# 2. The MIDI instrument name, if distinct across all staves using it.
952						# 3. "Staff-N" (1-based) as the unconditional last resort.
953						#
954						# After candidates are chosen, any name that appears more than once is
955						# replaced with "Staff-N" to guarantee unique part names in the output.
956						sub _resolve_part_names {
957	185			185	101	my ($staves) = @_;
958
959						# Build candidates
960	185				77	my @candidates;
961	185				80	my $n = 1;
962	185				111	for my $staff (@$staves) {
963	390				251	push @candidates, _candidate_part_name($staff, $n++);
964						}
965
966						# Count how many staves share each candidate name
967	185				114	my %freq;
968	185				591	$freq{$_}++ for @candidates;
969
970						# Replace any duplicated name with a positional "Staff-N" fallback
971	185				97	my @resolved;
972	185				68	my $pos = 1;
973	185				110	for my $cand (@candidates) {
974	390	100			270	push @resolved, $freq{$cand} > 1 ? "Staff-$pos" : $cand;
975	390				148	$pos++;
976						}
977
978	185				247	return @resolved;
979						}
980
981						# Return a candidate name for one staff before deduplication.
982						sub _candidate_part_name {
983	390			390	188	my ($staff, $part_num) = @_;
984	390		50		256	my $name = $staff->name // '';
985
986						# Accept the NWC name unless it matches NWC's own generic defaults
987						# ("Staff", "Staff-0" .. "Staff-99").
988	390	100	67		649	return $name if length $name && $name !~ /^Staff(?:-\d+)?$/i;
989
990						# Try the instrument name recorded in the MIDI settings.
991	126		50		99	my $instr = $staff->instrument // {};
992						return $instr->{name}
993	126	100	67		243	if defined $instr->{name} && length $instr->{name};
994
995						# Positional fallback: 1-based "Staff-N".
996	8				8	return "Staff-$part_num";
997						}
998
999						sub _emit_parts {
1000	181			181	120	my ($self, $staves, $divisions) = @_;
1001	181				72	my @out;
1002	181				72	my $part_id = 1;
1003	181				112	for my $staff (@$staves) {
1004	383				576	push @out, $self->_emit_part("P$part_id", $staff, $divisions);
1005	383				21203	$part_id++;
1006						}
1007	181				185166	return @out;
1008						}
1009
1010						sub _emit_part {
1011	383			383	332	my ($self, $id, $staff, $divisions) = @_;
1012	383				144	my @out;
1013
1014	383				340	push @out, "<part id=\"$id\">";
1015
1016	383				187	my $measure_no = 1;
1017	383				215	my @pending = ();
1018	383				156	my $first = 1;
1019	383				189	my $prev_bar = 'normal';
1020
1021						# $clef_start / $key_start = state at the beginning of the current measure.
1022						# $clef_now / $key_now = state updated live as we scan events.
1023						# They diverge when Clef/Key events appear mid-measure; at each Bar we
1024						# commit the live values as the start-of-next-measure state.
1025	383		100		361	my $clef_start = $staff->initial_clef // 'Treble';
1026	383		100 100		350	my $key_start = ($staff->initial_key // {})->{fifths} // 0;
1027	383				209	my $clef_now = $clef_start;
1028	383				177	my $key_now = $key_start;
1029
1030						# Expose per-staff DynVel map for _emit_dynamic to use during this part.
1031	383				284	$self->{_dyn_vel} = $staff->{_dyn_vel};
1032
1033						# Pre-annotate all events with slur/tie and wedge metadata in one pass
1034						# so that arcs crossing bar lines are handled correctly.
1035	383				319	my $ann = $self->_annotate_events($staff->events);
1036	383				422	$self->_annotate_wedges($staff->events, $ann);
1037	383				293	$self->_annotate_lyrics($staff->events, $ann);
1038
1039	383 383				154 248	for my $event (@{ $staff->events }) {
1040	203059				82207	my $type = $event->type;
1041
1042	203059	100 100 100			87003	if ($type eq 'Bar') {
1043	45250		50		16305	my $bar_style = $event->data->{style} // 'normal';
1044	45250				21889	push @out, $self->_emit_measure(
1045						$measure_no++, \@pending, $staff, $divisions,
1046						$first, $clef_start, $key_start, $prev_bar, $bar_style, $ann
1047						);
1048	45250				35911	@pending = ();
1049	45250				12272	$first = 0;
1050	45250				13492	$prev_bar = $bar_style;
1051	45250				12752	$clef_start = $clef_now; # carry updated state to next measure
1052	45250				15997	$key_start = $key_now;
1053
1054						} elsif ($type eq 'Clef') {
1055	206		33		195	$clef_now = $event->data->{nwc_clef} // $clef_now;
1056	206				109	push @pending, $event; # included so _emit_measure can emit <attributes>
1057
1058						} elsif ($type eq 'Key') {
1059	581		50 50		341	$key_now = ($event->data // {})->{fifths} // 0;
1060	581				277	push @pending, $event;
1061
1062						} else {
1063	157022				52211	push @pending, $event;
1064						}
1065						}
1066
1067	383	100	100		382	if (@pending \|\| $measure_no == 1) {
1068						push @out, $self->_emit_measure(
1069						$measure_no, \@pending, $staff, $divisions,
1070						$first, $clef_start, $key_start, $prev_bar,
1071	147		100		459	$staff->{_ending_bar} // 'normal', $ann
1072						);
1073						}
1074
1075	383				294	delete $self->{_dyn_vel};
1076	383				184	push @out, "</part>";
1077	383				181769	return @out;
1078						}
1079
1080						sub _emit_measure {
1081	45397			45397	22929	my ($self, $number, $events, $staff, $divisions, $is_first,
1082						$clef, $key_fifths, $prev_bar, $bar_style, $ann) = @_;
1083	45397		50		16779	my $curr_clef = $clef // 'Treble';
1084	45397		50		16707	my $curr_key = $key_fifths // 0;
1085	45397		50		16269	$prev_bar //= 'normal';
1086	45397		50		15351	$bar_style //= 'normal';
1087	45397		50		16070	$ann //= {};
1088
1089	45397				11984	my @out;
1090	45397				13806	my $i = $self->{_indent};
1091	45397				12405	my $pad = $i;
1092	45397				12687	my $bar_accidentals = {}; # pitch_key -> alter; reset each measure
1093
1094	45397				19036	push @out, "${pad}<measure number=\"$number\">";
1095
1096	45397	100	67		28042	if ($prev_bar eq 'MasterRepeatOpen' \|\| $prev_bar eq 'LocalRepeatOpen') {
1097	464				284	push @out, "${pad}${i}<barline location=\"left\">";
1098	464				390	push @out, "${pad}${i}${i}<bar-style>heavy-light</bar-style>";
1099	464				287	push @out, "${pad}${i}${i}<repeat direction=\"forward\"/>";
1100	464				217	push @out, "${pad}${i}</barline>";
1101						}
1102
1103	45397	100			17381	if ($is_first) {
1104	383				504	push @out, $self->_emit_attributes($staff, $divisions, $pad . $i);
1105						# Emit MIDI playback volume/pan at the start of the first measure.
1106	383				351	my ($vol, $pan) = ($staff->{_volume}, $staff->{_stereo_pan});
1107	383	100	67		363	if (defined $vol \|\| defined $pan) {
1108	116				58	my @sa;
1109	116	50			544	push @sa, sprintf('dynamics="%d"', int($vol * 100 / 127 + 0.5)) if defined $vol;
1110	116	50			163	push @sa, sprintf('pan="%d"', int(($pan - 64) * 90 / 63 + 0.5)) if defined $pan;
1111	116	50			282	push @out, "${pad}${i}<sound " . join(' ', @sa) . '/>' if @sa;
1112						}
1113						}
1114
1115	45397				14748	for my $event (@$events) {
1116	157809				62942	my $type = $event->type;
1117	157809		100		107208	my $ev_ann = $ann->{"$event"} // {};
1118
1119	157809	100 100 100 100 100 100 100 50 50 50 100 100 100			152885	if ($type eq 'TimeSig') {
1120	2320		50		1170	push @out, $self->_emit_time_change($event->data // {}, $pad . $i);
1121
1122						} elsif ($type eq 'Clef') {
1123	206		33		132	$curr_clef = $event->data->{nwc_clef} // $curr_clef;
1124	206				286	push @out, $self->_emit_clef_change($curr_clef, $pad . $i);
1125
1126						} elsif ($type eq 'Key') {
1127	581		50		321	my $kd = $event->data // {};
1128	581		50		373	$curr_key = $kd->{fifths} // 0;
1129	581				651	push @out, $self->_emit_key_change($kd, $pad . $i);
1130
1131						} elsif ($type eq 'Tempo') {
1132	153		50		86	my $d = $event->data // {};
1133						push @out, $self->_emit_tempo(
1134	153				248	$d->{bpm}, $d->{base}, $pad . $i);
1135
1136						} elsif ($type eq 'Dynamic') {
1137	2902		50		1184	my $d = $event->data // {};
1138						push @out, $self->_emit_dynamic(
1139	2902				2483	$d->{marking}, $d->{placement}, $pad . $i);
1140
1141						} elsif ($type eq 'DynVariance') {
1142	1		50		1	my $d = $event->data // {};
1143						push @out, $self->_emit_wedge(
1144	1				2	$d->{style}, $d->{placement}, $pad . $i);
1145
1146						} elsif ($type eq 'TempoVariance') {
1147	121		50		102	my $d = $event->data // {};
1148						push @out, $self->_emit_tempo_variance(
1149	121				210	$d->{style}, $d->{placement}, $pad . $i);
1150
1151						} elsif ($type eq 'Text') {
1152	0		0		0	my $d = $event->data // {};
1153						push @out, $self->_emit_text_direction(
1154	0				0	$d->{text}, $d->{placement}, $pad . $i);
1155
1156						} elsif ($type eq 'FlowControl') {
1157	0		0		0	my $d = $event->data // {};
1158	0				0	push @out, $self->_emit_flow_control($d->{directive}, $pad . $i);
1159
1160						} elsif ($type eq 'Instrument') {
1161	0		0		0	my $d = $event->data // {};
1162						push @out, $self->_emit_instrument_change(
1163	0				0	$d->{name}, $d->{patch}, $pad . $i);
1164
1165						} elsif ($type eq 'Note') {
1166						push @out, $self->_emit_wedge($ev_ann->{wedge_start}, undef, $pad . $i)
1167	103094	100			41896	if $ev_ann->{wedge_start};
1168	103094				49792	push @out, $self->_emit_note_event(
1169						$event, $curr_clef, $curr_key, $divisions, $pad . $i, 0, $ev_ann, $bar_accidentals);
1170						push @out, $self->_emit_wedge('crescOff', undef, $pad . $i)
1171	103094	100			65398	if $ev_ann->{wedge_stop_after};
1172						} elsif ($type eq 'Rest') {
1173						push @out, $self->_emit_wedge($ev_ann->{wedge_start}, undef, $pad . $i)
1174	23461	50			9068	if $ev_ann->{wedge_start};
1175	23461				11538	push @out, $self->_emit_rest_event($event, $divisions, $pad . $i, $ev_ann);
1176						push @out, $self->_emit_wedge('crescOff', undef, $pad . $i)
1177	23461	50			13545	if $ev_ann->{wedge_stop_after};
1178						} elsif ($type eq 'Chord') {
1179						push @out, $self->_emit_wedge($ev_ann->{wedge_start}, undef, $pad . $i)
1180	24911	100			10366	if $ev_ann->{wedge_start};
1181	24911				13677	push @out, $self->_emit_chord_event(
1182						$event, $curr_clef, $curr_key, $divisions, $pad . $i, $ev_ann, $bar_accidentals);
1183						push @out, $self->_emit_wedge('crescOff', undef, $pad . $i)
1184	24911	100			21108	if $ev_ann->{wedge_stop_after};
1185						}
1186						}
1187
1188	45397	100 100 100	67		33943	if ($bar_style eq 'MasterRepeatClose') {
1189	464				314	push @out, "${pad}${i}<barline location=\"right\">";
1190	464				362	push @out, "${pad}${i}${i}<bar-style>light-heavy</bar-style>";
1191	464				252	push @out, "${pad}${i}${i}<repeat direction=\"backward\"/>";
1192	464				253	push @out, "${pad}${i}</barline>";
1193						} elsif ($bar_style eq 'Double') {
1194	928				590	push @out, "${pad}${i}<barline location=\"right\">";
1195	928				559	push @out, "${pad}${i}${i}<bar-style>light-light</bar-style>";
1196	928				466	push @out, "${pad}${i}</barline>";
1197						} elsif ($bar_style eq 'SectionClose' \|\| $bar_style eq 'LocalRepeatClose') {
1198	1				1	push @out, "${pad}${i}<barline location=\"right\">";
1199	1				1	push @out, "${pad}${i}${i}<bar-style>light-heavy</bar-style>";
1200	1				1	push @out, "${pad}${i}</barline>";
1201						}
1202
1203	45397				16070	push @out, "${pad}</measure>";
1204	45397				150519	return @out;
1205						}
1206
1207						# ---------------------------------------------------------------------------
1208						# Private: slur / tie annotation pass
1209						# ---------------------------------------------------------------------------
1210
1211						# Walk all events in a staff once and build an annotation hashref keyed by
1212						# stringified event reference. Each value is a hashref with:
1213						# slur_start => 1 this note opens a slur arc
1214						# slur_stop => 1 this note closes a slur arc
1215						# tie_stop_keys => { pos_key => 1, ... } tie stops arriving at this note
1216						# tie_start_keys => { pos_key => 1, ... } tie starts leaving from this note
1217						#
1218						# "pos_key" is the raw position string with any ^ suffix stripped, used as an
1219						# opaque key to match the tied-to note. Ties that cross measure boundaries are
1220						# handled correctly because we walk the entire event list before grouping.
1221
1222						sub _annotate_events {
1223	386			386	236	my ($self, $events) = @_;
1224	386				175	my %ann;
1225
1226	386				176	my $in_slur = 0;
1227	386				159	my $slur_num = 0;
1228	386				226	my $last_slur_ev = undef;
1229	386				169	my $last_slur_num = 0;
1230	386				167	my %pending_tie; # pos_key => 1 for notes awaiting a tie-stop
1231
1232	386				288	for my $ev (@$events) {
1233	203065				102830	my $type = $ev->type;
1234	203065	100	100		121541	next unless $type eq 'Note' \|\| $type eq 'Chord' \|\| $type eq 'Rest';
1235
1236	151472				49113	my $key = "$ev"; # stringified reference, unique per object
1237
1238						# Tie tracking (not applicable to rests)
1239	151472	100			53172	unless ($type eq 'Rest') {
1240						my @pos_strs = $type eq 'Chord'
1241	24911		50		8583	? @{$ev->data->{nwc_positions} // []}
1242	128011	100	50		50643	: ($ev->data->{nwc_pos} // '0');
1243
1244	128011				38608	for my $ps (@pos_strs) {
1245	162463				50407	(my $pk = $ps) =~ s/\^\z//; # strip tie marker to get the key
1246
1247	162463	100			56258	if (delete $pending_tie{$pk}) {
1248	5424				5046	$ann{$key}{tie_stop_keys}{$pk} = 1;
1249						}
1250	162463	100			70805	if ($ps =~ /\^\z/) {
1251	5482				5621	$ann{$key}{tie_start_keys}{$pk} = 1;
1252	5482				2337	$pending_tie{$pk} = 1;
1253						}
1254						}
1255						}
1256
1257						# Slur tracking (not applicable to rests â€” rests are inside slur spans
1258						# but don't carry the arc endpoint markers)
1259	151472	100			55631	next if $type eq 'Rest';
1260
1261	128011 37638 128011		100	37638	51599 14683 44741	my $has_slur = any { $_ eq 'Slur' } @{$ev->data->{articulations} // []};
1262
1263	128011	100			57694	if ($has_slur) {
1264	24609	100			8885	unless ($in_slur) {
1265	6098				1894	$slur_num = ($slur_num % $MAX_SLUR_NUMBER) + 1;
1266	6098				15267	$ann{$key}{slur_start} = $slur_num;
1267	6098				1722	$in_slur = 1;
1268						}
1269						# Rolling assignment: only the last slurred note's key matters for
1270						# slur_stop; intermediate dead-stores are intentional.
1271	24609				6735	$last_slur_ev = $key;
1272	24609				10413	$last_slur_num = $slur_num;
1273						} else {
1274	103402	100			48618	if ($in_slur) {
1275	6094				11163	$ann{$last_slur_ev}{slur_stop} = $last_slur_num;
1276	6094				1759	$in_slur = 0;
1277	6094				2536	$last_slur_ev = undef;
1278						}
1279						}
1280						}
1281
1282						# Close any slur still open at the end of the staff
1283	386	100	67		299	$ann{$last_slur_ev}{slur_stop} = $last_slur_num if $in_slur && defined $last_slur_ev;
1284
1285	386				306	return \%ann;
1286						}
1287
1288						# Associate each Lyric event with the immediately preceding Note or Chord event.
1289						# Lyric events in NWCTXT always follow the note they annotate.
1290						sub _annotate_lyrics {
1291	383			383	242	my ($self, $events, $ann) = @_;
1292	383		50		243	$ann //= {};
1293
1294	383				153	my $last_note_key;
1295	383				208	for my $ev (@$events) {
1296	203059				69167	my $type = $ev->type;
1297	203059	100 50	33 100		107392	if ($type eq 'Note' \|\| $type eq 'Chord') {
1298	128005				41485	$last_note_key = "$ev";
1299						} elsif ($type eq 'Lyric' && defined $last_note_key) {
1300	0		0		0	my $d = $ev->data // {};
1301	0				0	push @{ $ann->{$last_note_key}{lyrics} }, {
1302						text => $d->{text} // '',
1303						verse => $d->{verse} // 1,
1304	0		0 0 0		0	syllabic => $d->{syllabic} // 'single',
1305						};
1306						}
1307						}
1308	383				176	return $ann;
1309						}
1310
1311						# Annotate wedge (hairpin) start/stop transitions into an existing %$ann hash.
1312						# NWC stores hairpins as Opts:Crescendo / Opts:Diminuendo on each note/rest/chord
1313						# under the arc, NOT as standalone DynVariance records.
1314						# Sets wedge_start => 'Crescendo'\|'Diminuendo' on the first event of each arc,
1315						# and wedge_stop_after => 1 on the last event of each arc.
1316						sub _annotate_wedges {
1317	386			386	298	my ($self, $events, $ann) = @_;
1318	386		50		248	$ann //= {};
1319
1320	386				203	my $wedge_now = undef; # 'Crescendo' \| 'Diminuendo' \| undef
1321	386				171	my $prev_wedge_key = undef; # stringified ref of last event under the arc
1322
1323	386				260	for my $ev (@$events) {
1324	203066				80552	my $type = $ev->type;
1325	203066	100	100		114528	next unless $type eq 'Note' \|\| $type eq 'Rest' \|\| $type eq 'Chord';
1326
1327	151473				47175	my $key = "$ev";
1328	151473		100		50898	my $opts = $ev->data->{opts} // {};
1329						my $ev_wedge = $opts->{Crescendo} ? 'Crescendo'
1330	151473	100 100			65292	: $opts->{Diminuendo} ? 'Diminuendo'
1331						: undef;
1332
1333	151473	100	100		51583	if (defined $wedge_now && (!defined $ev_wedge \|\| $ev_wedge ne $wedge_now)) {
1334	1135	50			956	$ann->{$prev_wedge_key}{wedge_stop_after} = 1 if defined $prev_wedge_key;
1335	1135				341	$wedge_now = undef;
1336						}
1337	151473	100	100		81319	if (!defined $wedge_now && defined $ev_wedge) {
1338	1139				1042	$ann->{$key}{wedge_start} = $ev_wedge;
1339	1139				391	$wedge_now = $ev_wedge;
1340						}
1341
1342	151473	100			55444	$prev_wedge_key = defined $ev_wedge ? $key : undef;
1343						}
1344
1345						# Close any arc still open at end of staff
1346	386	100	67		287	$ann->{$prev_wedge_key}{wedge_stop_after} = 1
1347						if defined $wedge_now && defined $prev_wedge_key;
1348
1349	386				191	return $ann;
1350						}
1351
1352						# ---------------------------------------------------------------------------
1353						# Private: note / rest / chord XML emission
1354						# ---------------------------------------------------------------------------
1355
1356						sub _emit_note_event {
1357	162457			162457	72170	my ($self, $event, $clef, $key_fifths, $divisions, $pad, $is_chord_member, $ev_ann, $bar_accidentals) = @_;
1358	162457		50		58287	$ev_ann //= {};
1359	162457		50		56126	$bar_accidentals //= {};
1360	162457				61665	my $d = $event->data;
1361	162457				47388	my @out;
1362	162457				49535	my $i = $self->{_indent};
1363
1364	162457		50		84627	my $pitch = $self->_pos_to_pitch($d->{nwc_pos} // '0', $clef, $key_fifths);
1365
1366						# Accidentals carry through the bar: once a pitch class is altered in a measure,
1367						# all subsequent notes at the same step+octave inherit that alteration.
1368	162457				61754	my $pitch_key = $pitch->{step} . $pitch->{octave};
1369	162457	100 100			74930	if (defined $pitch->{accidental}) {
1370	10819				5512	$bar_accidentals->{$pitch_key} = $pitch->{alter};
1371						} elsif (exists $bar_accidentals->{$pitch_key}) {
1372	5570				2254	$pitch->{alter} = $bar_accidentals->{$pitch_key};
1373						}
1374	162457				66784	my $ticks = _rational_to_ticks($event->duration, $divisions);
1375	162457		50 50		120210	my $type = $NWC_TYPE_MAP{ $d->{base_dur} // '4th' } // 'quarter';
1376
1377						# Tie flags for this specific position key
1378	162457		50		265861	(my $pk = $d->{nwc_pos} // '0') =~ s/\^\z//;
1379	162457		100		83359	my $tie_stop = ($ev_ann->{tie_stop_keys} // {})->{$pk};
1380	162457		100		83004	my $tie_start = ($ev_ann->{tie_start_keys} // {})->{$pk};
1381
1382						# Slur flags: only the first note of a chord carries the arc endpoints
1383	162457		100		84388	my $slur_start = !$is_chord_member && $ev_ann->{slur_start};
1384	162457		100		76348	my $slur_stop = !$is_chord_member && $ev_ann->{slur_stop};
1385
1386	162457				61068	push @out, "${pad}<note>";
1387	162457	100			64809	push @out, "${pad}${i}<chord/>" if $is_chord_member;
1388	162457	100			64079	push @out, "${pad}${i}<grace/>" if $d->{is_grace};
1389	162457				61232	push @out, "${pad}${i}<pitch>";
1390	162457				70770	push @out, "${pad}${i}${i}<step>$pitch->{step}</step>";
1391	162457	100			67525	push @out, "${pad}${i}${i}<alter>$pitch->{alter}</alter>" if $pitch->{alter};
1392	162457				69394	push @out, "${pad}${i}${i}<octave>$pitch->{octave}</octave>";
1393	162457				62072	push @out, "${pad}${i}</pitch>";
1394	162457	100			59469	unless ($d->{is_grace}) {
1395	162456				64844	push @out, "${pad}${i}<duration>$ticks</duration>";
1396						# <tie> elements come after <duration> and before <voice> per MusicXML schema
1397	162456	100			55956	push @out, "${pad}${i}<tie type=\"stop\"/>" if $tie_stop;
1398	162456	100			58070	push @out, "${pad}${i}<tie type=\"start\"/>" if $tie_start;
1399						}
1400	162457				58820	push @out, "${pad}${i}<voice>1</voice>";
1401	162457				64979	push @out, "${pad}${i}<type>$type</type>";
1402	162457		100		86801	push @out, "${pad}${i}<dot/>" for 1 .. ($d->{dots} // 0);
1403						push @out, "${pad}${i}<accidental>$pitch->{accidental}</accidental>"
1404	162457	100			62484	if $pitch->{accidental};
1405
1406						# <notations> block
1407	162457				42780	my @nots;
1408	162457	100			54218	push @nots, "${pad}${i}${i}<tied type=\"stop\"/>" if $tie_stop;
1409	162457	100			54121	push @nots, "${pad}${i}${i}<tied type=\"start\"/>" if $tie_start;
1410	162457	100			59589	push @nots, "${pad}${i}${i}<slur number=\"$slur_stop\" type=\"stop\"/>" if $slur_stop;
1411	162457	100			55583	push @nots, "${pad}${i}${i}<slur number=\"$slur_start\" type=\"start\"/>" if $slur_start;
1412
1413						# Articulations: only on the first note of a chord (is_chord_member is false)
1414						my @artic_tokens = !$is_chord_member
1415	162457 37635 128005	100	100		59569 17255 64412	? grep { $_ ne 'Slur' } @{ $d->{articulations} // [] }
1416						: ();
1417	162457	100			58672	if (@artic_tokens) {
1418	12854				3858	my (@artic_els, @ornament_els, @direct_els);
1419	12854				4138	for my $tok (@artic_tokens) {
1420	13029				8006	my $map = $ARTICULATION_MAP{$tok};
1421	13029	100			18806	if (!defined $map) {
1422	1				0	carp _fmt_msg('warn_unsupported_art', $tok);
1423	1				4	next;
1424						}
1425	13028 13026	100 100			6674 20748	if ($map->{group} eq 'articulations') { push @artic_els, $map->{element} }
1426	1				4	elsif ($map->{group} eq 'ornaments') { push @ornament_els, $map->{element} }
1427	1				4	else { push @direct_els, $map->{element} }
1428						}
1429	12854	100			20781	if (@artic_els) {
1430	12851				5116	push @nots, "${pad}${i}${i}<articulations>";
1431	12851				6913	push @nots, "${pad}${i}${i}${i}<$_/>" for @artic_els;
1432	12851				5135	push @nots, "${pad}${i}${i}</articulations>";
1433						}
1434	12854	100			4699	if (@ornament_els) {
1435	1				1	push @nots, "${pad}${i}${i}<ornaments>";
1436	1				2	push @nots, "${pad}${i}${i}${i}<$_/>" for @ornament_els;
1437	1				0	push @nots, "${pad}${i}${i}</ornaments>";
1438						}
1439	12854				5015	push @nots, "${pad}${i}${i}<$_/>" for @direct_els;
1440						}
1441
1442	162457	100			57077	if (@nots) {
1443	32846				11773	push @out, "${pad}${i}<notations>";
1444	32846				11052	push @out, @nots;
1445	32846				12369	push @out, "${pad}${i}</notations>";
1446						}
1447
1448						# Lyrics: only on the first note of a chord (is_chord_member is false).
1449	162457	100			57930	unless ($is_chord_member) {
1450	128005 128005		50		33286 73967	for my $lyric (@{ $ev_ann->{lyrics} // [] }) {
1451	0		0		0	my $num = $lyric->{verse} // 1;
1452	0		0		0	my $syllabic = $lyric->{syllabic} // 'single';
1453	0		0		0	my $text = _xml_escape($lyric->{text} // '');
1454	0				0	push @out, "${pad}${i}<lyric number=\"$num\">";
1455	0				0	push @out, "${pad}${i}${i}<syllabic>$syllabic</syllabic>";
1456	0				0	push @out, "${pad}${i}${i}<text>$text</text>";
1457	0				0	push @out, "${pad}${i}</lyric>";
1458						}
1459						}
1460
1461	162457				65649	push @out, "${pad}</note>";
1462	162457				206595	return @out;
1463						}
1464
1465						sub _emit_rest_event {
1466	23461			23461	9289	my ($self, $event, $divisions, $pad, $ev_ann) = @_;
1467	23461		50		8262	$ev_ann //= {};
1468	23461				9104	my $d = $event->data;
1469	23461				6654	my @out;
1470	23461				7120	my $i = $self->{_indent};
1471
1472	23461				8589	my $ticks = _rational_to_ticks($event->duration, $divisions);
1473	23461		50 50		19746	my $type = $NWC_TYPE_MAP{ $d->{base_dur} // '4th' } // 'quarter';
1474
1475	23461				35923	push @out, "${pad}<note>";
1476	23461				8822	push @out, "${pad}${i}<rest/>";
1477	23461				9660	push @out, "${pad}${i}<duration>$ticks</duration>";
1478	23461				8275	push @out, "${pad}${i}<voice>1</voice>";
1479	23461				9216	push @out, "${pad}${i}<type>$type</type>";
1480	23461		50		12936	push @out, "${pad}${i}<dot/>" for 1 .. ($d->{dots} // 0);
1481	23461				8565	push @out, "${pad}</note>";
1482	23461				18514	return @out;
1483						}
1484
1485						sub _emit_chord_event {
1486	24911			24911	12080	my ($self, $event, $clef, $key_fifths, $divisions, $pad, $ev_ann, $bar_accidentals) = @_;
1487	24911		50		9411	$ev_ann //= {};
1488	24911		50		9320	$bar_accidentals //= {};
1489	24911				9518	my $d = $event->data;
1490	24911				7217	my @out;
1491
1492	24911		50		13479	my $positions = $d->{nwc_positions} // ['0'];
1493	24911				7330	my $first = 1;
1494
1495	24911				10527	for my $pos_str (@$positions) {
1496						# Build a per-position annotation that inherits slur flags (first note only)
1497						# and picks the tie flags for this specific position key.
1498	59363				23572	(my $pk = $pos_str) =~ s/\^\z//;
1499						my %pos_ann = (
1500						tie_stop_keys => { $pk => ($ev_ann->{tie_stop_keys} // {})->{$pk} // 0 },
1501						tie_start_keys => { $pk => ($ev_ann->{tie_start_keys} // {})->{$pk} // 0 },
1502						($first ? (
1503						slur_start => $ev_ann->{slur_start},
1504						slur_stop => $ev_ann->{slur_stop},
1505						lyrics => $ev_ann->{lyrics},
1506	59363	100	100 100 100 100		105413	) : ()),
1507						);
1508	59363				28458	push @out, $self->_emit_note_event(
1509						_chord_note_event($event, $pos_str),
1510						$clef, $key_fifths, $divisions, $pad, !$first, \%pos_ann, $bar_accidentals
1511						);
1512	59363				62934	$first = 0;
1513						}
1514	24911				47041	return @out;
1515						}
1516
1517						# Build a synthetic Note event for one pitch member of a Chord.
1518						# Uses Event->new so that validation, rational reduction and the
1519						# public accessor contract are all preserved.
1520						sub _chord_note_event {
1521	59363			59363	22035	my ($chord_event, $pos_str) = @_;
1522	59363				22746	my $d = $chord_event->data;
1523						return Music::NWC2MusicXML::Event->new(
1524						type => 'Note',
1525						duration => $chord_event->duration,
1526						data => {
1527						nwc_pos => $pos_str,
1528						base_dur => $d->{base_dur},
1529						dots => $d->{dots} // 0,
1530						articulations => $d->{articulations} // [],
1531						is_grace => $d->{is_grace},
1532						},
1533	59363		50 50		25646	);
1534						}
1535
1536						# ---------------------------------------------------------------------------
1537						# Private: pitch conversion
1538						# ---------------------------------------------------------------------------
1539
1540						# Convert an NWC position string (e.g. "#-6", "b3", "-9^") to a MusicXML
1541						# pitch descriptor { step, octave, alter, accidental }.
1542						#
1543						# Position 0 = middle line (3rd from bottom) of the staff (clef-specific).
1544						# Negative positions go DOWN the staff; positive positions go UP.
1545						# Formula: diatonic_index = octave*7 + step_index + pos_num
1546						sub _pos_to_pitch {
1547	162474			162474	78920	my ($self, $pos_str, $clef, $key_fifths) = @_;
1548	162474		50		59709	$pos_str //= '0';
1549	162474		50		54454	$clef //= 'Treble';
1550	162474		50		58454	$key_fifths //= 0;
1551
1552						# Parse: optional accidental prefix + signed integer + optional tie marker
1553	162474				56056	my ($acc_prefix, $pos_num) = ('', 0);
1554	162474	50			102646	if ($pos_str =~ /\A([#bnx]*)(-?\d+)\^?\z/) {
1555	162474				79152	($acc_prefix, $pos_num) = ($1, $2 + 0);
1556						}
1557
1558	162474		67		94219	my $ref = $CLEF_REF{$clef} // $CLEF_REF{Treble};
1559	162474				263265	my $index = $ref->[1] * 7 + $ref->[0] + $pos_num;
1560
1561	162474				393098	my $octave = floor($index / 7);
1562	162474				54497	my $step_i = $index - $octave * 7;
1563
1564	162474				67749	my $step = $STEP_NAMES[$step_i];
1565	162474				221397	my $key_alt = _key_alter_for_step($step_i, $key_fifths);
1566
1567						# Dispatch: known prefixes from %ACCIDENTAL_MAP; empty/unknown -> key-sig alter.
1568	162474				84927	my ($alter, $accidental);
1569	162474	100			85255	if (my $acc = $ACCIDENTAL_MAP{$acc_prefix}) {
1570	10828				17168	($alter, $accidental) = @$acc;
1571						} else {
1572	151646				198687	$alter = $key_alt;
1573	151646				40308	$accidental = undef;
1574						}
1575
1576	162474				151247	return { step => $step, octave => $octave, alter => $alter, accidental => $accidental };
1577						}
1578
1579						sub _key_alter_for_step {
1580	162474			162474	53953	my ($step_i, $key_fifths) = @_;
1581	162474	100			61858	return 0 unless $key_fifths;
1582
1583						# P1: $key_fifths != 0 (guarded above). P2: sharp/flat differ only in sign+table.
1584	131694	100			55421	my ($sign, $steps) = $key_fifths > 0
1585						? (1, \@SHARP_STEPS)
1586						: (-1, \@FLAT_STEPS);
1587	131694	100			47255	my $n = abs($key_fifths) > 7 ? 7 : abs($key_fifths);
1588	131694				46399	for my $k (0 .. $n - 1) {
1589	261627	100			247872	return $sign if $steps->[$k] == $step_i;
1590						}
1591	102864				140278	return 0;
1592						}
1593
1594						sub _rational_to_ticks {
1595	185923			185923	65167	my ($rational, $divisions) = @_;
1596	185923				111557	return int($rational->[0] * $divisions / $rational->[1] + 0.5);
1597						}
1598
1599						sub _emit_tempo {
1600	153			153	135	my ($self, $bpm, $base, $pad) = @_;
1601	153				87	my $i = $self->{_indent};
1602	153		50		105	$bpm //= 120;
1603	153		50		89	$base //= 'Quarter';
1604
1605	153		33		160	my $map = $TEMPO_BASE_MAP{$base} // $TEMPO_BASE_MAP{Quarter};
1606	153				370	my $unit = $map->{unit};
1607	153				308	my $dot = $map->{dot};
1608	153				306	my $sound_bpm = int($bpm * $map->{factor} + 0.5);
1609
1610	153				286	my @out;
1611	153				100	push @out, "${pad}<direction placement=\"above\">";
1612	153				75	push @out, "${pad}${i}<direction-type>";
1613	153				100	push @out, "${pad}${i}${i}<metronome parentheses=\"no\">";
1614	153				105	push @out, "${pad}${i}${i}${i}<beat-unit>$unit</beat-unit>";
1615	153	100			107	push @out, "${pad}${i}${i}${i}<beat-unit-dot/>" if $dot;
1616	153				127	push @out, "${pad}${i}${i}${i}<per-minute>$bpm</per-minute>";
1617	153				96	push @out, "${pad}${i}${i}</metronome>";
1618	153				94	push @out, "${pad}${i}</direction-type>";
1619	153				100	push @out, "${pad}${i}<sound tempo=\"$sound_bpm\"/>";
1620	153				74	push @out, "${pad}</direction>";
1621	153				252	return @out;
1622						}
1623
1624						sub _emit_dynamic {
1625	2907			2907	4576	my ($self, $marking, $placement, $pad) = @_;
1626	2907				1012	my $i = $self->{_indent};
1627	2907		50		1143	$marking //= '';
1628	2907		50		1194	$placement //= '';
1629
1630	2907	100			1907	unless (exists $DYNAMIC_MAP{$marking}) {
1631	2	100			6	carp _fmt_msg('warn_unknown_dynamic', $marking) if $marking ne '';
1632	2				149	return ();
1633						}
1634
1635	2905	100			5676	my $place = (lc($placement) eq 'above') ? 'above' : 'below';
1636	2905				842	my @out;
1637	2905				1256	push @out, "${pad}<direction placement=\"$place\">";
1638	2905				1166	push @out, "${pad}${i}<direction-type>";
1639	2905				1310	push @out, "${pad}${i}${i}<dynamics>";
1640	2905				1390	push @out, "${pad}${i}${i}${i}<$marking/>";
1641	2905				1322	push @out, "${pad}${i}${i}</dynamics>";
1642	2905				1167	push @out, "${pad}${i}</direction-type>";
1643	2905				1095	my $dyn_vel = $self->{_dyn_vel};
1644	2905	100	67		2614	if (defined $dyn_vel && defined $dyn_vel->{$marking}) {
1645	2901				1454	my $pct = int($dyn_vel->{$marking} * 100 / 127 + 0.5);
1646	2901				1516	push @out, "${pad}${i}<sound dynamics=\"$pct\"/>";
1647						}
1648	2905				1146	push @out, "${pad}</direction>";
1649	2905				3928	return @out;
1650						}
1651
1652						# Map NWC DynVariance style -> MusicXML wedge type
1653						Readonly::Hash my %WEDGE_MAP => (
1654						Crescendo => 'crescendo',
1655						Diminuendo => 'diminuendo',
1656						crescOff => 'stop',
1657						);
1658
1659						sub _emit_wedge {
1660	2276			2276	3005	my ($self, $style, $placement, $pad) = @_;
1661	2276				825	my $i = $self->{_indent};
1662	2276		50		1079	$style //= '';
1663	2276		100		1980	$placement //= '';
1664
1665	2276				1605	my $wedge_type = $WEDGE_MAP{$style};
1666	2276	100			4046	return () unless defined $wedge_type;
1667
1668	2275	100			1158	my $place = (lc($placement) eq 'above') ? 'above' : 'below';
1669	2275				652	my @out;
1670	2275				1143	push @out, "${pad}<direction placement=\"$place\">";
1671	2275				1057	push @out, "${pad}${i}<direction-type>";
1672	2275				1104	push @out, "${pad}${i}${i}<wedge type=\"$wedge_type\" number=\"1\"/>";
1673	2275				974	push @out, "${pad}${i}</direction-type>";
1674	2275				920	push @out, "${pad}</direction>";
1675	2275				2086	return @out;
1676						}
1677
1678						Readonly::Hash my %TEMPO_VARIANCE_TEXT => (
1679						Accelerando => 'accel.',
1680						Ritardando => 'rit.',
1681						Rallentando => 'rall.',
1682						RitardandoToTempo => 'a tempo',
1683						Stringendo => 'string.',
1684						Breath => "\x{2019}", # right single quotation mark used as breath comma
1685						Caesura => '//',
1686						);
1687
1688						sub _emit_tempo_variance {
1689	121			121	121	my ($self, $style, $placement, $pad) = @_;
1690	121		50		82	$style //= '';
1691	121		50		92	$placement //= 'above';
1692	121				54	my $i = $self->{_indent};
1693
1694	121		33		130	my $text = _xml_escape($TEMPO_VARIANCE_TEXT{$style} // $style);
1695	121	50			125	return () unless length $text;
1696
1697	121	50			136	my $place = (lc($placement) eq 'above') ? 'above' : 'below';
1698	121				44	my @out;
1699	121				117	push @out, "${pad}<direction placement=\"$place\">";
1700	121				79	push @out, "${pad}${i}<direction-type>";
1701	121				177	push @out, "${pad}${i}${i}<words font-style=\"italic\">$text</words>";
1702	121				88	push @out, "${pad}${i}</direction-type>";
1703	121				73	push @out, "${pad}</direction>";
1704	121				146	return @out;
1705						}
1706
1707						sub _emit_text_direction {
1708	0			0	0	my ($self, $text, $placement, $pad) = @_;
1709	0		0		0	$text //= '';
1710	0		0		0	$placement //= '';
1711	0	0			0	return () unless length $text;
1712	0				0	my $i = $self->{_indent};
1713	0	0			0	my $place = (lc($placement) eq 'above') ? 'above' : 'below';
1714	0				0	my @out;
1715	0				0	push @out, "${pad}<direction placement=\"$place\">";
1716	0				0	push @out, "${pad}${i}<direction-type>";
1717	0				0	push @out, "${pad}${i}${i}<words>" . _xml_escape($text) . "</words>";
1718	0				0	push @out, "${pad}${i}</direction-type>";
1719	0				0	push @out, "${pad}</direction>";
1720	0				0	return @out;
1721						}
1722
1723						sub _emit_flow_control {
1724	0			0	0	my ($self, $directive, $pad) = @_;
1725	0		0		0	$directive //= '';
1726	0				0	my $map = $FLOW_CONTROL_MAP{$directive};
1727	0	0			0	return () unless defined $map;
1728	0				0	my $i = $self->{_indent};
1729	0				0	my @out;
1730	0				0	push @out, "${pad}<direction placement=\"above\">";
1731	0	0			0	if (defined $map->{element}) {
1732	0				0	push @out, "${pad}${i}<direction-type>";
1733	0				0	push @out, "${pad}${i}${i}<$map->{element}/>";
1734	0				0	push @out, "${pad}${i}</direction-type>";
1735						}
1736	0	0			0	if (defined $map->{words}) {
1737	0				0	push @out, "${pad}${i}<direction-type>";
1738						push @out, "${pad}${i}${i}<words font-style=\"italic\">"
1739	0				0	. _xml_escape($map->{words}) . "</words>";
1740	0				0	push @out, "${pad}${i}</direction-type>";
1741						}
1742	0				0	push @out, "${pad}</direction>";
1743	0				0	return @out;
1744						}
1745
1746						sub _emit_instrument_change {
1747	0			0	0	my ($self, $name, $patch, $pad) = @_;
1748	0				0	my $i = $self->{_indent};
1749	0		0		0	my $prog = ($patch // 0) + 1;
1750	0	0			0	my $text = $name ? _xml_escape($name) : "Program $prog";
1751	0				0	my @out;
1752	0				0	push @out, "${pad}<direction placement=\"above\">";
1753	0				0	push @out, "${pad}${i}<direction-type>";
1754	0				0	push @out, "${pad}${i}${i}<other-direction>$text</other-direction>";
1755	0				0	push @out, "${pad}${i}</direction-type>";
1756	0				0	push @out, "${pad}</direction>";
1757	0				0	return @out;
1758						}
1759
1760						sub _emit_time_change {
1761	2320			2320	1104	my ($self, $ts_data, $pad) = @_;
1762	2320				663	my @out;
1763	2320				834	my $i = $self->{_indent};
1764	2320		50		1263	my $beats = $ts_data->{beats} // 4;
1765	2320		50		1113	my $beat_type = $ts_data->{beat_type} // 4;
1766
1767	2320				983	push @out, "${pad}<attributes>";
1768	2320				941	push @out, "${pad}${i}<time>";
1769	2320				1131	push @out, "${pad}${i}${i}<beats>$beats</beats>";
1770	2320				1111	push @out, "${pad}${i}${i}<beat-type>$beat_type</beat-type>";
1771	2320				910	push @out, "${pad}${i}</time>";
1772	2320				880	push @out, "${pad}</attributes>";
1773	2320				2602	return @out;
1774						}
1775
1776						sub _emit_clef_change {
1777	206			206	154	my ($self, $clef_name, $pad) = @_;
1778	206				90	my @out;
1779	206				99	my $i = $self->{_indent};
1780	206		33		187	my $clef = $CLEF_MAP{$clef_name} // $CLEF_MAP{Treble};
1781
1782	206				524	push @out, "${pad}<attributes>";
1783	206				154	push @out, "${pad}${i}<clef>";
1784	206				234	push @out, "${pad}${i}${i}<sign>$clef->{sign}</sign>";
1785						push @out, "${pad}${i}${i}<line>$clef->{line}</line>"
1786	206	50			501	if defined $clef->{line};
1787	206				868	push @out, "${pad}${i}</clef>";
1788	206				108	push @out, "${pad}</attributes>";
1789	206				252	return @out;
1790						}
1791
1792						sub _emit_key_change {
1793	581			581	397	my ($self, $key_data, $pad) = @_;
1794	581				201	my @out;
1795	581				306	my $i = $self->{_indent};
1796	581		50		381	my $fifths = $key_data->{fifths} // 0;
1797
1798	581				329	push @out, "${pad}<attributes>";
1799	581				354	push @out, "${pad}${i}<key>";
1800	581				374	push @out, "${pad}${i}${i}<fifths>$fifths</fifths>";
1801	581				306	push @out, "${pad}${i}</key>";
1802	581				327	push @out, "${pad}</attributes>";
1803	581				638	return @out;
1804						}
1805
1806						sub _emit_attributes {
1807	383			383	258	my ($self, $staff, $divisions, $pad) = @_;
1808	383				139	my @out;
1809	383				220	my $i = $self->{_indent};
1810
1811	383				257	push @out, "${pad}<attributes>";
1812	383				296	push @out, "${pad}${i}<divisions>$divisions</divisions>";
1813
1814	383	100			295	if (my $key = $staff->initial_key) {
1815	208				182	push @out, "${pad}${i}<key>";
1816	208				213	push @out, "${pad}${i}${i}<fifths>$key->{fifths}</fifths>";
1817	208				168	push @out, "${pad}${i}</key>";
1818						}
1819
1820	383	100			730	if (my $ts = $staff->initial_timesig) {
1821	206				155	push @out, "${pad}${i}<time>";
1822	206				234	push @out, "${pad}${i}${i}<beats>$ts->{beats}</beats>";
1823	206				190	push @out, "${pad}${i}${i}<beat-type>$ts->{beat_type}</beat-type>";
1824	206				146	push @out, "${pad}${i}</time>";
1825						}
1826
1827	383	100			238	if (my $clef_name = $staff->initial_clef) {
1828	238				128	push @out, "${pad}${i}<clef>";
1829	238				510	my $clef = $CLEF_MAP{$clef_name};
1830	238	100			698	unless (defined $clef) {
1831	1				2	carp _fmt_msg('warn_unknown_clef', $clef_name);
1832	1				205	$clef = $CLEF_MAP{Treble};
1833						}
1834	238				271	push @out, "${pad}${i}${i}<sign>$clef->{sign}</sign>";
1835						push @out, "${pad}${i}${i}<line>$clef->{line}</line>"
1836	238	100			650	if defined $clef->{line};
1837	238				960	push @out, "${pad}${i}</clef>";
1838						}
1839
1840	383		100 50		290	my $trans = ($staff->instrument // {})->{trans} // 0;
1841	383	50			256	if ($trans) {
1842	0				0	push @out, "${pad}${i}<transpose>";
1843	0				0	push @out, "${pad}${i}${i}<chromatic>$trans</chromatic>";
1844	0				0	push @out, "${pad}${i}</transpose>";
1845						}
1846
1847	383				238	push @out, "${pad}</attributes>";
1848	383				513	return @out;
1849						}
1850
1851						# ---------------------------------------------------------------------------
1852						# Private: divisions calculation
1853						# ---------------------------------------------------------------------------
1854
1855						# Strategy: collect the denominator of every rational duration encountered
1856						# across all staves, then compute their LCM. The divisions value is that LCM,
1857						# guaranteeing exact integer representation for every duration tick count.
1858
1859						sub _calculate_divisions {
1860	185			185	138	my ($self, $score) = @_;
1861
1862	185				96	my %seen_denoms;
1863	185 185				186 165	for my $staff (@{ $score->staves }) {
1864	386 386				180 378	for my $event (@{ $staff->events }) {
1865	203065				86962	my $d = $event->duration->[1];
1866	203065	50			82886	$seen_denoms{$d} = 1 if $d > 0;
1867						}
1868						}
1869
1870	185	100			183	return $DEFAULT_DIVISIONS unless %seen_denoms;
1871
1872	180				179	my @denoms = keys %seen_denoms;
1873	180				103	my $lcm = $denoms[0];
1874	180				236	for my $d (@denoms[1..$#denoms]) {
1875	63				90	$lcm = _lcm($lcm, $d);
1876						}
1877
1878	180				195	return $lcm;
1879						}
1880
1881						# ---------------------------------------------------------------------------
1882						# Private: XML helpers
1883						# ---------------------------------------------------------------------------
1884
1885						# Pre-built table for single-pass XML character escaping.
1886						# Covers the five XML-special ASCII chars; non-ASCII get numeric char refs.
1887						Readonly::Hash my %XML_ESCAPE_MAP => (
1888						'&' => '&',
1889						'<' => '<',
1890						'>' => '>',
1891						'"' => '"',
1892						"'" => ''',
1893						);
1894
1895						sub _xml_escape {
1896	1097			1097	12597	my ($s) = @_;
1897	1097	100			520	return '' unless defined $s;
1898						# Pass 1: strip XML 1.0 illegal control bytes (cannot appear even as &#N;).
1899	1094				647	$s =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g;
1900						# Pass 2: escape XML specials and numeric-ref non-ASCII in a single scan.
1901	1094 251		67		1179 630	$s =~ s/([&<>"']\|[^\x00-\x7F])/$XML_ESCAPE_MAP{$1} \/\/ sprintf "&#%d;", ord($1)/ge;
1902	1094				1257	return $s;
1903						}
1904
1905						sub _lcm {
1906	66			66	64	my ($a, $b) = @_;
1907	66				71	return $a / _gcd($a, $b) * $b;
1908						}
1909
1910						sub _gcd {
1911	68			68	827	my ($a, $b) = @_;
1912	68				134	($a, $b) = ($b, $a % $b) while $b;
1913	68				124	return $a;
1914						}
1915
1916						sub _fmt_msg {
1917	19			19	16	my ($key, @args) = @_;
1918	19	50			27	croak "Unknown message key: $key" unless exists $MESSAGES{$key};
1919	19				63	return sprintf $MESSAGES{$key}, @args;
1920						}
1921
1922						1;
1923