From 603b25831ac38fa505cbc61349eec10ffe036ec5 Mon Sep 17 00:00:00 2001 From: Christoph Wagner Date: Mon, 6 Apr 2026 13:14:58 +0200 Subject: [PATCH] Chordpro export --- .gitignore | 2 +- private_includes/base/all.ily | 1 + .../base/basic_format_and_style_settings.ily | 11 + private_includes/base/chord_settings.ily | 31 +- private_includes/base/chordpro.ily | 1040 +++++++++++++++++ private_includes/base/verses_with_chords.ily | 2 + public_includes/layout_bottom.ily | 38 +- public_includes/pool_bottom.ily | 2 +- 8 files changed, 1101 insertions(+), 26 deletions(-) create mode 100644 private_includes/base/chordpro.ily diff --git a/.gitignore b/.gitignore index a5cbf12..d97ba6c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,8 @@ # ---> Lilypond *.pdf +*.cho *.ps *.midi *.mid *.log *~ - diff --git a/private_includes/base/all.ily b/private_includes/base/all.ily index 40e022c..75816a6 100644 --- a/private_includes/base/all.ily +++ b/private_includes/base/all.ily @@ -38,6 +38,7 @@ \include "eps_file_from_song_dir.ily" \include "title_with_category_images.ily" \include "chord_settings.ily" +\include "chordpro.ily" \include "transposition.ily" \include "verses_with_chords.ily" \include "arrows_in_scores.ily" diff --git a/private_includes/base/basic_format_and_style_settings.ily b/private_includes/base/basic_format_and_style_settings.ily index 2826352..f10548e 100644 --- a/private_includes/base/basic_format_and_style_settings.ily +++ b/private_includes/base/basic_format_and_style_settings.ily @@ -158,6 +158,8 @@ override-stanza = #(define (stanza . stanzanumbers) #{ \once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs + \once \override StanzaNumber.details.custom-stanza-type = #'verse + \once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers \applyContext #(lambda (context) (handle-stanza-numbers context stanzanumbers @@ -169,6 +171,8 @@ ref = #(define-music-function (stanzanumbers lyrics) ((number-list? (list)) ly:music?) #{ \lyricmode { \once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs + \once \override StanzaNumber.details.custom-stanza-type = #'ref + \once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers \applyContext #(lambda (context) (handle-stanza-numbers context stanzanumbers @@ -186,6 +190,8 @@ bridge = #(define-music-function (stanzanumbers lyrics) ((number-list? (list)) ly:music?) #{ \lyricmode { \once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs + \once \override StanzaNumber.details.custom-stanza-type = #'bridge + \once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers \applyContext #(lambda (context) (handle-stanza-numbers context stanzanumbers @@ -201,8 +207,11 @@ bridge = % prints a repStart Sign as stanza if the tag 'repeats is kept. % if there was a stanza already set by the stanza function with StanzaNumber.details.custom-realstanza = ##t we set that also as stanza. +% Sets custom-inline-text for ChordPro export so it can collect the repeat sign separately repStartWithTag = \lyricmode { \tag #'repeats { + \once \override StanzaNumber.details.custom-inline-text = \repStart + \once \override StanzaNumber.details.custom-inline-direction = #LEFT \applyContext #(lambda (context) (let ((lastStanza (ly:context-property context 'stanza)) @@ -220,6 +229,8 @@ repStartWithTag = \lyricmode { repStopWithTag = \lyricmode { \tag #'repeats { + \once \override StanzaNumber.details.custom-inline-text = \repStop + \once \override StanzaNumber.details.custom-inline-direction = #RIGHT \once \override StanzaNumber.font-series = #'normal \once \override StanzaNumber.direction = 1 \set stanza = \markup { \pad-x-right #1 \repStop } diff --git a/private_includes/base/chord_settings.ily b/private_includes/base/chord_settings.ily index ea06e48..4cd332d 100644 --- a/private_includes/base/chord_settings.ily +++ b/private_includes/base/chord_settings.ily @@ -40,34 +40,19 @@ shiftChords = #(define-music-function (parser location xshift chords) (number? l altChord = #(define-music-function (parser location mainchord altchord) (ly:music? ly:music?) - (let* ((remove-point-and-click - (lambda (grob) - (ly:grob-set-property! grob 'cause #f) - (ly:text-interface::print grob))) - (chord-name (lambda (in-pitches bass inversion context) #{ - \markup { - \translate #'(-0.5 . 0) - \score { - \chords { \transposable #(cons (car (music-pitches mainchord)) (car in-pitches)) { #(music-clone mainchord) \klamm #(music-clone altchord) } } - \layout { - \LAYOUT - \context { - \ChordNames - \override ChordName.extra-spacing-width = #'(0 . 0.3) - \override ChordName.stencil = #remove-point-and-click - } - \context { - \Score - \override SpacingSpanner.spacing-increment = 0 - } - } - } - }#}))) + (let* ((chord-name (lambda (in-pitches bass inversion context) + (make-line-markup (list + (ignatzek-chord-names in-pitches bass inversion context) + (make-hspace-markup 0.3) + (parenthesis-ignatzek-chord-names (music-pitches (transposable (cons (car (music-pitches mainchord)) (car in-pitches)) (music-clone altchord))) '() '() context) + )) + ))) #{ \once \set chordNameFunction = #chord-name #mainchord #})) + % Akkorde werden so transponiert, dass sie passen, wenn man mit Kapo im angegebenen Bund spielt capoTranspose = #(define-music-function (fret chords) (number? ly:music?) diff --git a/private_includes/base/chordpro.ily b/private_includes/base/chordpro.ily new file mode 100644 index 0000000..6ab9c04 --- /dev/null +++ b/private_includes/base/chordpro.ily @@ -0,0 +1,1040 @@ +%% ChordPro Export Engraver +%% ========================= +%% Single engraver in Score context that collects all data + +#(use-modules (ice-9 format)) +#(use-modules (srfi srfi-1)) + +%% Helper function to convert German minor chord notation to standard major form +%% Used for generating {define:} directives +#(define (german-minor-to-major-form chord-str) + "Convert lowercase German minor chords (e.g., 'a7', 'fis') to standard form (e.g., 'Am7', 'Fism')" + (if (or (not (string? chord-str)) (string-null? chord-str)) + chord-str + (let* ((first-char (string-ref chord-str 0))) + (if (char-lower-case? first-char) + ;; It's a minor chord - capitalize first letter and add 'm' after accidentals + (let* ((rest-str (if (> (string-length chord-str) 1) + (substring chord-str 1) + "")) + ;; Find where to insert 'm': after 'is' or 'es' if present, otherwise right after root + (insert-pos (cond + ((string-prefix? "is" rest-str) 2) + ((string-prefix? "es" rest-str) 2) + (else 0))) + (before-m (substring rest-str 0 insert-pos)) + (after-m (substring rest-str insert-pos))) + (string-append (string (char-upcase first-char)) before-m "m" after-m)) + ;; Already uppercase - return as is + chord-str)))) + +%% Helper function to convert German accidentals to international format +#(define (german-accidentals-to-international chord-str) + "Convert German 'is' to '#' and 'es' to 'b' (e.g., 'fis' -> 'F#', 'as' -> 'Ab')" + (if (or (not (string? chord-str)) (string-null? chord-str)) + chord-str + (let* ((first-char (string-ref chord-str 0)) + (rest-str (if (> (string-length chord-str) 1) + (substring chord-str 1) + "")) + ;; Check for 'is' (sharp) or 'es' (flat) + (has-is (string-prefix? "is" rest-str)) + (has-es (string-prefix? "es" rest-str)) + ;; Convert root note + (root-upper (string (char-upcase first-char))) + ;; Process accidentals and rest + (processed-rest + (cond + (has-is ; fis -> F#, cis -> C# + (string-append "#" (substring rest-str 2))) + (has-es ; as -> Ab, es -> Eb + (string-append "b" (substring rest-str 2))) + (else rest-str)))) + ;; Special case: if it's a minor chord (lowercase), add 'm' after accidental + (if (char-lower-case? first-char) + ;; Minor: add 'm' after accidental + (if (or has-is has-es) + (string-append root-upper (substring processed-rest 0 1) "m" (substring processed-rest 1)) + (string-append root-upper "m" processed-rest)) + ;; Major: just return converted + (string-append root-upper processed-rest))))) + +%% Helper function to convert B/b chords to Bb/Bbm form for {define:} directives +#(define (german-b-to-bb-form chord-str) + "Convert B/b chords to Bb/Bbm format (e.g., 'B7' -> 'Bb7', 'b' -> 'Bbm', 'b7' -> 'Bbm7')" + (if (or (not (string? chord-str)) (string-null? chord-str)) + chord-str + (let ((first-char (string-ref chord-str 0))) + (cond + ;; Uppercase B -> Bb + rest + ((char=? first-char #\B) + (string-append "Bb" (substring chord-str 1))) + ;; Lowercase b -> Bbm + rest (it's b-minor) + ((char=? first-char #\b) + (let ((rest-str (if (> (string-length chord-str) 1) + (substring chord-str 1) + ""))) + (string-append "Bbm" rest-str))) + (else chord-str))))) + +%% Helper function to convert H/h chords to B/Bm form for {define:} directives +#(define (german-h-to-b-form chord-str) + "Convert H/h chords to B/Bm format (e.g., 'H7' -> 'B7', 'h' -> 'Bm', 'h7' -> 'Bm7')" + (if (or (not (string? chord-str)) (string-null? chord-str)) + chord-str + (let ((first-char (string-ref chord-str 0))) + (cond + ;; Uppercase H -> B + rest + ((char=? first-char #\H) + (string-append "B" (substring chord-str 1))) + ;; Lowercase h -> Bm + rest (it's h-minor) + ((char=? first-char #\h) + (let ((rest-str (if (> (string-length chord-str) 1) + (substring chord-str 1) + ""))) + (string-append "Bm" rest-str))) + (else chord-str))))) + +%% Helper function to track minor/B/H/accidental chords and return original +#(define (track-and-return-chord chord-str) + "Track chords that need {define:} directives and return original." + (if (or (not (string? chord-str)) (string-null? chord-str)) + chord-str + (let* ((first-char (string-ref chord-str 0)) + (rest-str (if (> (string-length chord-str) 1) + (substring chord-str 1) + "")) + (has-is (string-prefix? "is" rest-str)) + (has-es (string-prefix? "es" rest-str)) + (has-accidental (or has-is has-es))) + (cond + ;; H/h chords (German H = English B) + ((char=? first-char #\H) + (unless (member chord-str chordpro-h-chords-used) + (set! chordpro-h-chords-used (cons chord-str chordpro-h-chords-used)))) + ((char=? first-char #\h) + (unless (member chord-str chordpro-h-chords-used) + (set! chordpro-h-chords-used (cons chord-str chordpro-h-chords-used)))) + + ;; B/b chords (German B = English Bb) + ((char=? first-char #\B) + (unless (member chord-str chordpro-b-chords-used) + (set! chordpro-b-chords-used (cons chord-str chordpro-b-chords-used)))) + ((char=? first-char #\b) + (unless (member chord-str chordpro-b-chords-used) + (set! chordpro-b-chords-used (cons chord-str chordpro-b-chords-used)))) + + ;; Chords with accidentals (is/es) + (has-accidental + (unless (member chord-str chordpro-accidental-chords-used) + (set! chordpro-accidental-chords-used (cons chord-str chordpro-accidental-chords-used)))) + + ;; Other lowercase chords (minor without B/H/accidentals) + ((char-lower-case? first-char) + (unless (member chord-str chordpro-minor-chords-used) + (set! chordpro-minor-chords-used (cons chord-str chordpro-minor-chords-used))))) + + ;; Always return original + chord-str))) + +%% Helper function to convert chord music object to chord name string +#(define (music-to-chord-name chord-music) + "Extract pitches from a chord music object and convert to German chord name" + (if (not chord-music) + "" + (let* ((pitches (music-pitches chord-music))) + (if (or (not pitches) (null? pitches)) + "" ; No pitches found + (let* (;; Use ignatzek chord naming with German root names + (chord-markup ((chord-name:name-markup 'deutsch) pitches #f #f #f)) + ;; Convert markup to string + (chord-str (if (markup? chord-markup) + (markup->string chord-markup) + "")) + ;; Remove spaces + (cleaned (string-delete #\space chord-str))) + cleaned))))) + +%% Helper function to normalize multiple spaces to single space +#(define (normalize-spaces str) + "Replace multiple consecutive spaces with a single space" + (let loop ((chars (string->list str)) + (result '()) + (prev-was-space #f)) + (if (null? chars) + (list->string (reverse result)) + (let ((char (car chars))) + (if (char=? char #\space) + (if prev-was-space + ;; Skip this space + (loop (cdr chars) result #t) + ;; Keep this space + (loop (cdr chars) (cons char result) #t)) + ;; Not a space + (loop (cdr chars) (cons char result) #f)))))) + +%% Helper function to extract chord names from markup, handling \altChord format +#(define (extract-chord-names-from-markup markup) + "Extract chord names from markup, handling complex structures like \altChord which produces 'B(Gm)' format" + (let* ((raw-str (cond + ((string? markup) markup) + ((markup? markup) (markup->string markup)) + ((pair? markup) (extract-chord-names-from-markup (car markup))) + (else (format #f "~a" markup)))) + ;; Remove all spaces + (clean-str (string-delete #\space raw-str))) + ;; Check if this is an altChord format: "B(Gm)" or similar + (if (string-index clean-str #\() + ;; Multiple chords: split by parentheses + (let* ((open-paren (string-index clean-str #\()) + (close-paren (string-index clean-str #\))) + (first-chord (substring clean-str 0 open-paren)) + (second-chord (if (and open-paren close-paren) + (substring clean-str (+ open-paren 1) close-paren) + ""))) + ;; Format as:[B][(Gm)] - first chord normal, second in parens + (string-append first-chord "][(" second-chord ")")) + ;; Single chord: return as is + clean-str))) + +%% Global state - shared across all engraver instances! +#(define chordpro-syllables-collected '()) +#(define chordpro-chords-collected '()) +#(define chordpro-breaks-collected '()) +#(define chordpro-stanza-numbers '()) +%% Format: (moment verse-idx text direction) for inline text markers like repStart/repStop +#(define chordpro-inline-texts-collected '()) +%%Track break moments to detect verse changes +#(define chordpro-seen-break-moments '()) +%% Increments with each verse (each chordlyrics call) +#(define chordpro-current-verse-index 0) +%% Collected minor chords (lowercase German chords) for {define:} directives +#(define chordpro-minor-chords-used '()) +%% Collected B chords (German B = English Bb) for {define:} directives +#(define chordpro-b-chords-used '()) +%% Collected H chords (German H = English B) for {define:} directives +#(define chordpro-h-chords-used '()) +%% Collected chords with accidentals (is/es) for {define:} directives +#(define chordpro-accidental-chords-used '()) + +%% Configuration and metadata (set by layout_bottom.ily or song file) +#(define chordpro-export-enabled #t) +#(define chordpro-current-filename "output") +#(define chordpro-header-title "Untitled") +#(define chordpro-header-authors #f) + +%% Write flag (ensures we only write once, not for each finalize call) +#(define chordpro-file-written #f) + +%% Helper function to format stanza label for ChordPro +#(define (format-chordpro-stanza-label stanza-type stanza-numbers) + "Generate ChordPro label based on stanza type and optional numbers" + (let* ((has-numbers (and stanza-numbers (not (null? stanza-numbers)))) + (numbers-string (if has-numbers + (string-join (map (lambda (n) (format #f "~a" n)) stanza-numbers) ", ") + ""))) + (cond + ((eq? stanza-type 'ref) + (if has-numbers + (format #f (if (defined? 'refStringWithNumbers) refStringWithNumbers "Ref. ~a:") numbers-string) + (if (defined? 'refString) refString "Ref.:"))) + ((eq? stanza-type 'bridge) + (if has-numbers + (format #f (if (defined? 'bridgeStringWithNumbers) bridgeStringWithNumbers "Bridge ~a:") numbers-string) + (if (defined? 'bridgeString) bridgeString "Bridge:"))) + (else #f)))) + +%% Single engraver in Score context +#(define ChordPro_score_collector + (lambda (context) + (let ((pending-syllable #f) + (this-verse-index #f)) + (make-engraver + ;; Initialize - called when engraver is created (once per \chordlyrics) + ((initialize engraver) + ;; Each \chordlyrics call creates a new Score, so this marks a new verse + (when (> chordpro-current-verse-index 0) + ;; Reset break tracking for new verse + (set! chordpro-seen-break-moments '())) + ;; Store the verse index for this instance + (set! this-verse-index chordpro-current-verse-index) + ;; Increment global index for next verse + (set! chordpro-current-verse-index (+ chordpro-current-verse-index 1))) + + ;; Event listeners + (listeners + ;; LyricEvent from Lyrics context + ((lyric-event engraver event) + (let ((text (ly:event-property event 'text)) + (moment (ly:context-current-moment context))) + (when (string? text) + ;; On first lyric event for this engraver instance, capture the verse index + (when (not this-verse-index) + (set! this-verse-index chordpro-current-verse-index) + (set! chordpro-current-verse-index (+ chordpro-current-verse-index 1))) + + ;; Save previous syllable if any (it had no hyphen) + (when pending-syllable + (set! chordpro-syllables-collected + (cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable)) + chordpro-syllables-collected))) + ;; Store new syllable as pending (with THIS instance's verse index) + (set! pending-syllable (list moment text this-verse-index))))) + + ;; HyphenEvent from Lyrics context + ((hyphen-event engraver event) + (when pending-syllable + (set! chordpro-syllables-collected + (cons (list (car pending-syllable) (cadr pending-syllable) #t (caddr pending-syllable)) + chordpro-syllables-collected)) + (set! pending-syllable #f))) + + ;; BreakEvent - store break moment + ((break-event engraver event) + (let ((moment (ly:context-current-moment context))) + + ;; Store break with this instance's verse index + (set! chordpro-breaks-collected + (cons (cons moment this-verse-index) chordpro-breaks-collected))))) + + ;; Acknowledge grobs from child contexts + (acknowledgers + ;; StanzaNumber grobs to extract stanza type and text + ((stanza-number-interface engraver grob source-engraver) + (let* ((details (ly:grob-property grob 'details '())) + (custom-realstanza (ly:assoc-get 'custom-realstanza details #f)) + (stanza-type (ly:assoc-get 'custom-stanza-type details 'verse)) + (stanza-numbers (ly:assoc-get 'custom-stanza-numbers details '())) + ;; Check for custom inline text (e.g., repStart/repStop with direction) + (custom-inline-text (ly:assoc-get 'custom-inline-text details #f)) + (custom-inline-direction (ly:assoc-get 'custom-inline-direction details CENTER)) + ;; Try to read stanza text from multiple sources: + ;; 1. From the grob's text property + (stanza-text-from-grob (ly:grob-property grob 'text #f)) + ;; 2. From the Lyrics context's stanza property + (lyrics-context (ly:translator-context source-engraver)) + (stanza-text-from-context (if lyrics-context + (ly:context-property lyrics-context 'stanza #f) + #f)) + ;; Use context property if available, otherwise grob property + (stanza-markup (or stanza-text-from-context stanza-text-from-grob)) + ;; For ref/bridge, always use format-chordpro-stanza-label + ;; For verse, extract from markup (includes roman numerals if \romanStanza was used) + (stanza-text (if (or (eq? stanza-type 'ref) (eq? stanza-type 'bridge)) + (format-chordpro-stanza-label stanza-type stanza-numbers) + (if (markup? stanza-markup) + (markup->string stanza-markup) + (if stanza-markup + (format #f "~a" stanza-markup) + #f)))) + (existing (assoc this-verse-index chordpro-stanza-numbers)) + (moment (ly:context-current-moment (ly:translator-context source-engraver))) + (direction (ly:grob-property grob 'direction CENTER))) + + ;; If custom-inline-text is set, always collect it as inline text (regardless of realstanza) + ;; This allows repStart/repStop to be collected even when combined with real stanza numbers + (when custom-inline-text + (set! chordpro-inline-texts-collected + (cons (list moment this-verse-index custom-inline-text custom-inline-direction) + chordpro-inline-texts-collected))) + + ;; If this is NOT a real stanza marker (custom-realstanza not set or ##f), + ;; collect it as inline text with direction info + (when (and (not custom-realstanza) (not custom-inline-text)) + (when stanza-text ; Only if there's text to display + (set! chordpro-inline-texts-collected + (cons (list moment this-verse-index stanza-text direction) + chordpro-inline-texts-collected)))) + + ;; Store or update stanza info for this verse (only if it's a real stanza marker) + ;; Entry format: (verse-idx stanza-text stanza-type realstanza-flag) + (when custom-realstanza + (if existing + ;; Update existing entry with type and text if available + ;; IMPORTANT: Don't overwrite realstanza=##t markers and their text + (let* ((existing-text (cadr existing)) + (existing-type (caddr existing)) + (existing-realstanza (if (> (length existing) 3) (cadddr existing) #f))) + (set! chordpro-stanza-numbers + (map (lambda (entry) + (if (= (car entry) this-verse-index) + (list (car entry) + ;; If existing entry is a real stanza, don't overwrite text + ;; Otherwise, use new text if available + (if existing-realstanza + existing-text + (or stanza-text existing-text)) + ;; Update type only if custom-realstanza is set + (if custom-realstanza stanza-type existing-type) + ;; Preserve ##t realstanza flag + (or existing-realstanza custom-realstanza)) + entry)) + chordpro-stanza-numbers))) + ;; Create new entry with type, text, and realstanza flag + (set! chordpro-stanza-numbers + (cons (list this-verse-index stanza-text stanza-type custom-realstanza) + chordpro-stanza-numbers)))))) ; closes set!, if, when, stanza-number-interface + + ;; ChordName grobs from ChordNames context + ;; Store grob reference - visibility will be recorded by ChordPro_chord_visibility_recorder + ((chord-name-interface engraver grob source-engraver) + (let* ((moment (ly:context-current-moment context)) + ;; Get details property to check for altChord + (details (ly:grob-property grob 'details '())) + (alt-main-name (assoc-get 'alt-chord-main-name details #f)) + (alt-alt-name (assoc-get 'alt-chord-alt-name details #f)) + ;; Extract chord name + (chord-name-final + (if (and alt-main-name alt-alt-name) + ;; This is an altChord - use the pre-extracted names + (let ((main (track-and-return-chord alt-main-name)) + (alt (track-and-return-chord alt-alt-name))) + ;; Check if main is empty - if so, only output alt in parens + (if (string-null? main) + (string-append "[(" alt ")]") ; Only alt chord: [(D7)] + ;; Format as: [B][(Gm)] (complete with all brackets) + (string-append "[" main "][(" alt ")]"))) + ;; Normal chord - extract from markup text + (let* ((chord-text (ly:grob-property grob 'text)) + (chord-names-str (extract-chord-names-from-markup chord-text)) + ;; Check if it contains "][(": multiple chords (shouldn't happen anymore) + (has-bracket (string-index chord-names-str #\]))) + (if has-bracket + ;; Multiple chords from old logic: manually split and process + (let* ((bracket-pos (string-index chord-names-str #\])) + (first-part (substring chord-names-str 0 bracket-pos)) + (rest (substring chord-names-str bracket-pos)) + (open-pos (string-index rest #\()) + (close-pos (string-index rest #\))) + (second-part (if (and open-pos close-pos) + (substring rest (+ open-pos 1) close-pos) + "")) + (first-converted (track-and-return-chord first-part)) + (second-converted (track-and-return-chord second-part))) + (string-append first-converted "][(" second-converted ")")) + ;; Single chord: just track and return original + (track-and-return-chord chord-names-str)))))) + ;; Store grob reference along with chord data (unless empty) + ;; Format: (moment chord-name verse-index grob) + ;; Filter out completely empty chords, but convert ][(X) to [(X)] + (let ((processed-chord-name + (cond + ;; Empty chord + ((or (string-null? chord-name-final) + (string=? chord-name-final "") + (string=? chord-name-final "][")) + #f) ; Filter out + ;; Pattern ][(X) - empty main, only alt in parens: convert to [(X)] + ((string-prefix? "][(" chord-name-final) + ;; ][(D7) → [(D7)] + (let* ((inner (substring chord-name-final 3 (- (string-length chord-name-final) 1)))) + (string-append "[(" inner ")]"))) + ;; Normal chord + (else chord-name-final)))) + (when processed-chord-name + (set! chordpro-chords-collected + (cons (list moment processed-chord-name this-verse-index grob) chordpro-chords-collected)))))) + + ;; LyricText grobs to get stanza number + ((lyric-syllable-interface engraver grob source-engraver) + (let* ((stanza-grob (ly:grob-property grob 'stanza #f)) + ;; Get the Lyrics context from the source engraver + (lyrics-context (ly:translator-context source-engraver)) + (stanza-context (if lyrics-context + (ly:context-property lyrics-context 'stanza #f) + #f)) + (stanza-value (or stanza-grob stanza-context))) + + (when stanza-value + ;; Only update existing stanza entries (don't create new ones) + ;; New entries should only be created by stanza-number-interface + (let* ((existing (assoc this-verse-index chordpro-stanza-numbers)) + (existing-text (if existing (cadr existing) #f)) + (stanza-text (if (markup? stanza-value) + (markup->string stanza-value) + (format #f "~a" stanza-value)))) + ;; Only update if entry exists and existing text is empty/false and new text is non-empty + (when (and existing + (not (and (string? existing-text) (not (string-null? existing-text)))) + (string? stanza-text) + (not (string-null? stanza-text))) + ;; Update existing entry with text (keep type and realstanza flag) + (set! chordpro-stanza-numbers + (map (lambda (entry) + (if (= (car entry) this-verse-index) + (list (car entry) + (or existing-text stanza-text) ; Keep existing text if present + (caddr entry) ; Keep stanza-type + (if (> (length entry) 3) (cadddr entry) #f)) ; Keep realstanza-flag if exists + entry)) + chordpro-stanza-numbers))))))) ; schließt lyric-syllable-interface + ) ; schließt acknowledgers + ;; End of timestep + ((stop-translation-timestep engraver) + (when pending-syllable + (set! chordpro-syllables-collected + (cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable)) + chordpro-syllables-collected)) + (set! pending-syllable #f))) + + ;; Finalize - just write debug, don't filter chords yet + ;; (Filtering happens in chordpro-write-from-engraver-data where grob properties are final) + ((finalize engraver) + ;; Save any remaining pending syllable + (when pending-syllable + (set! chordpro-syllables-collected + (cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable)) + chordpro-syllables-collected)) + (set! pending-syllable #f)) + + ;; Write debug output (overwrite each time, final version will be complete) + (with-output-to-file "/tmp/chordpro_debug.txt" + (lambda () + (display (format #f "ChordPro: Collected ~a syllables, ~a chords (unfiltered), ~a breaks, ~a verses\n" + (length chordpro-syllables-collected) + (length chordpro-chords-collected) + (length chordpro-breaks-collected) + chordpro-current-verse-index)) + (display "All syllables:\n") + (for-each + (lambda (syl) + (display (format #f " V~a: '~a' hyphen=~a at ~a\n" + (cadddr syl) (cadr syl) (if (caddr syl) "YES" "NO") (car syl)))) + (reverse chordpro-syllables-collected)) + (newline) + (display "Breaks:\n") + (for-each + (lambda (brk) + (display (format #f " V~a at ~a\n" (cdr brk) (car brk)))) + (reverse chordpro-breaks-collected)) + (newline) + (display "All chords (after visibility filtering):\n") + (for-each + (lambda (chord) + (display (format #f " V~a: ~a at ~a\n" + (caddr chord) (cadr chord) (car chord)))) + (reverse chordpro-chords-collected)) + (newline) + (display "Stanza numbers:\n") + (for-each + (lambda (stanza-entry) + (display (format #f " V~a: '~a' (type: ~a, real: ~a)\n" + (car stanza-entry) (cadr stanza-entry) (caddr stanza-entry) (cadddr stanza-entry)))) + (reverse chordpro-stanza-numbers)) + (newline) + (display "Inline texts (repStart/repStop etc.):\n") + (for-each + (lambda (inline-entry) + (display (format #f " V~a: '~a' at ~a (dir: ~a)\n" + (cadr inline-entry) (caddr inline-entry) (car inline-entry) (cadddr inline-entry)))) + (reverse chordpro-inline-texts-collected))))) + + )))) + +%% Helper functions to format and write ChordPro +#(define (chordpro-write-from-engraver-data num-verses) + "Write ChordPro file from collected engraver data" + (let* ((filename (if (defined? 'chordpro-current-filename) + chordpro-current-filename + "output")) + (output-file (string-append filename ".cho")) + ;; Reverse all lists (they were collected in reverse order) + (syllables (reverse chordpro-syllables-collected)) + (chords (reverse chordpro-chords-collected)) + (breaks (reverse chordpro-breaks-collected))) + + (with-output-to-file output-file + (lambda () + ;; Write metadata + (display (format #f "{title: ~a}\n" + (if (defined? 'chordpro-header-title) + chordpro-header-title + "Untitled"))) + (when (and (defined? 'chordpro-header-authors) chordpro-header-authors) + (display (format #f "{artist: ~a}\n" + (format-chordpro-authors chordpro-header-authors)))) + + ;; Write {define:} directives for all used minor chords + (unless (null? chordpro-minor-chords-used) + (newline) + (for-each + (lambda (minor-chord) + ;; Convert minor chord to major form for the definition + (let ((major-form (german-minor-to-major-form minor-chord))) + (display (format #f "{define: ~a copy ~a}\n" minor-chord major-form)))) + (reverse chordpro-minor-chords-used))) + + ;; Write {define:} directives for all used B chords (German B = English Bb) + (unless (null? chordpro-b-chords-used) + (for-each + (lambda (b-chord) + ;; Convert B/b to Bb/Bbm form for the definition + (let ((bb-form (german-b-to-bb-form b-chord))) + (display (format #f "{define: ~a copy ~a}\n" b-chord bb-form)))) + (reverse chordpro-b-chords-used))) + + ;; Write {define:} directives for all used H chords (German H = English B) + (unless (null? chordpro-h-chords-used) + (for-each + (lambda (h-chord) + ;; Convert H/h to B/Bm form for the definition + (let ((b-form (german-h-to-b-form h-chord))) + (display (format #f "{define: ~a copy ~a}\n" h-chord b-form)))) + (reverse chordpro-h-chords-used))) + + ;; Write {define:} directives for chords with accidentals (is/es -> #/b) + (unless (null? chordpro-accidental-chords-used) + (for-each + (lambda (accidental-chord) + ;; Convert German accidentals to international format + (let ((intl-form (german-accidentals-to-international accidental-chord))) + (display (format #f "{define: ~a copy ~a}\n" accidental-chord intl-form)))) + (reverse chordpro-accidental-chords-used))) + + (newline) + + ;; Write each verse in reverse order (they were collected backwards) + (let loop ((verse-idx (- num-verses 1))) + (when (>= verse-idx 0) + ;; Get syllables, chords and breaks for this verse + (let* ((verse-syllables (filter (lambda (s) (= (cadddr s) verse-idx)) syllables)) + (verse-chords-raw (filter (lambda (c) + (and (list? c) + (>= (length c) 3) + (= (caddr c) verse-idx))) + chords)) + ;; Simple filtering: remove repeated consecutive chords + (verse-chords (let filter-repeats ((chords-left verse-chords-raw) + (last-chord #f) + (result '())) + (if (null? chords-left) + (reverse result) + (let* ((chord (car chords-left)) + (chord-name (cadr chord))) + (if (equal? chord-name last-chord) + ;; Skip repeated chord + (filter-repeats (cdr chords-left) last-chord result) + ;; Include new chord + (filter-repeats (cdr chords-left) chord-name + (cons (list (car chord) chord-name (caddr chord)) result))))))) + (verse-breaks (filter (lambda (b) (= (cdr b) verse-idx)) breaks)) + (verse-inline-texts (filter (lambda (r) (= (cadr r) verse-idx)) + (reverse chordpro-inline-texts-collected))) + ;; Get stanza info (number, type, and realstanza flag) for this verse + (stanza-entry (find (lambda (s) (= (car s) verse-idx)) chordpro-stanza-numbers)) + (stanza-num (if stanza-entry (cadr stanza-entry) #f)) + (stanza-type (if stanza-entry (caddr stanza-entry) 'verse)) + (realstanza (if stanza-entry (cadddr stanza-entry) #f)) + ;; Determine ChordPro directive based on type + (start-directive (cond + ((eq? stanza-type 'ref) "start_of_chorus") + ((eq? stanza-type 'bridge) "start_of_bridge") + (else "start_of_verse"))) + (end-directive (cond + ((eq? stanza-type 'ref) "end_of_chorus") + ((eq? stanza-type 'bridge) "end_of_bridge") + (else "end_of_verse")))) + + (when (not (null? verse-syllables)) + ;; If realstanza is ##t, output with ChordPro directives + ;; Otherwise, just output the text (e.g., for repStartWithTag/repStopWithTag) + (if realstanza + (begin + (if (and stanza-num (not (string-null? stanza-num))) + (display (format #f "{~a: label=\"~a\"}\n" start-directive stanza-num)) + (display (format #f "{~a}\n" start-directive))) + (display (format-verse-as-chordpro verse-syllables verse-chords verse-breaks verse-inline-texts)) + (display (format #f "\n{~a}\n\n" end-directive))) + (begin + ;; For non-real stanzas, just output stanza marker as comment if present + (when (and stanza-num (not (string-null? stanza-num))) + (display (format #f "# ~a\n" stanza-num))) + (display (format-verse-as-chordpro verse-syllables verse-chords verse-breaks verse-inline-texts)) + (display "\n\n")))) + + (loop (- verse-idx 1))))))) + + )) + +#(define (format-verse-as-chordpro syllables chords breaks inline-texts) + "Format one verse as ChordPro text with line breaks. + Chords are placed at syllable boundaries, not word boundaries. + Inline texts (𝄆 𝄇 etc.) are inserted based on their direction property." + (let* (;; Get break moments + (break-moments (sort (map (lambda (b) (ly:moment-main (car b))) breaks) <)) + ;; Map each chord to the nearest following syllable + (chord-to-syllable-map (map-chords-to-syllables chords syllables)) + ;; Sort inline texts by moment + (sorted-inline-texts (sort inline-texts (lambda (a b) (ly:moment (ly:moment-main (car c)) syl-moment)) syl-chords)) + ;; Filter suffix chords: only keep those where NO line break exists between syllable and chord + ;; If a break is between the syllable and chord, the chord belongs to the next line + (suffix-chords (filter (lambda (c) + (let ((chord-moment (ly:moment-main (car c)))) + ;; Keep chord if no break exists, or if break is not between syl and chord + (or (null? breaks-left) + (let ((next-break (car breaks-left))) + ;; Only keep if break is AFTER the chord (or before/at syllable) + ;; Reject if: syl-moment < next-break <= chord-moment + (not (and (> next-break syl-moment) + (<= next-break chord-moment))))))) + suffix-chords-all)) + ;; Collect chords that were filtered out - they belong to the next line + (next-line-chords (filter (lambda (c) + (let ((chord-moment (ly:moment-main (car c)))) + (and (not (null? breaks-left)) + (let ((next-break (car breaks-left))) + (and (> next-break syl-moment) + (<= next-break chord-moment)))))) + suffix-chords-all)) + ;; Create chord prefix: add space after chord if it plays on a rest (before syllable) + (chord-prefix (if (null? prefix-chords) + "" + (string-join + (map (lambda (c) + (let* ((chord-moment (ly:moment-main (car c))) + (chord-name (cadr c)) + ;; Check if chord plays before syllable (on a rest) + (on-rest? (< chord-moment syl-moment)) + ;; Check if chord already has brackets + (has-brackets (string-prefix? "[" chord-name))) + (if has-brackets + ;; Already has brackets - just add space if needed + (if on-rest? + (string-append chord-name " ") + chord-name) + ;; Add brackets + (if on-rest? + (string-append "[" chord-name "] ") + (string-append "[" chord-name "]"))))) + prefix-chords) + ""))) + ;; Create chord suffix for chords that play after the syllable (on rests) + (chord-suffix (if (null? suffix-chords) + "" + (string-join + (map (lambda (c) + (let ((chord-name (cadr c))) + ;; Check if chord already has brackets (e.g., "[(D7)]") + (if (string-prefix? "[" chord-name) + chord-name ; Already has brackets + (string-append "[" chord-name "]")))) + suffix-chords) + ""))) + ;; Check for line break + (next-syl-moment (if (null? rest-syls) 999999 (ly:moment-main (car (car rest-syls))))) + (break-here (and (not (null? breaks-left)) + (let ((next-break (car breaks-left))) + (and (> next-break syl-moment) + (<= next-break next-syl-moment)))))) + + ;; Check for inline texts at this syllable position + (let* ((inline-result + (let collect-inlines ((inls inlines-left) (collected '())) + (if (or (null? inls) + (let ((inl-entry (car inls))) + (> (ly:moment-main (car inl-entry)) syl-moment))) + (list (reverse collected) inls) + (collect-inlines (cdr inls) (cons (car inls) collected))))) + (inlines-to-insert (car inline-result)) + (new-inlines-left (cadr inline-result)) + ;; Separate by direction: LEFT texts go before, RIGHT texts go after + (before-texts (filter (lambda (i) (eqv? (cadddr i) LEFT)) inlines-to-insert)) + (after-texts (filter (lambda (i) (eqv? (cadddr i) RIGHT)) inlines-to-insert))) + + ;; If this is the start of a new line and we have pending chords from the previous line + (when (and (null? current-line) (not (null? pending-line-chords))) + ;; If we're continuing a word (current-word-parts not empty), add chords as infix + ;; Otherwise add them as a separate word-like element + (if (not (null? current-word-parts)) + ;; Add pending chords as infix to the last word part + (let* ((last-part (car current-word-parts)) + (rest-parts (cdr current-word-parts)) + (pending-chord-str (string-join + (map (lambda (c) + (let ((chord-name (cadr c))) + (if (string-prefix? "[" chord-name) + chord-name ; Already has brackets + (string-append "[" chord-name "]")))) + pending-line-chords) + ""))) + (set! current-word-parts (cons (string-append last-part pending-chord-str) rest-parts))) + ;; No word continuation - add as separate element + (let ((pending-chord-str (string-join + (map (lambda (c) + (let ((chord-name (cadr c))) + (if (string-prefix? "[" chord-name) + chord-name ; Already has brackets + (string-append "[" chord-name "]")))) + pending-line-chords) + ""))) + (set! current-line (cons pending-chord-str current-line))))) + + ;; Insert texts that should appear BEFORE the syllable (direction = LEFT) + (for-each + (lambda (inline-text) + (set! current-line (cons (caddr inline-text) current-line))) + before-texts) + + ;; Track word start + (when (null? current-word-parts) + (set! word-start-moment syl-moment)) + + ;; Add text to current word only if syllable is not empty (not a lyric extender _) + ;; Handle chords: if we're continuing a word (current-word-parts not empty), + ;; prefix chords should be inserted between syllables as infixes (without trailing space) + (unless (string-null? syl-text) + (if (null? current-word-parts) + ;; First syllable of word: use prefix as normal + (set! current-word-parts (cons (string-append chord-prefix syl-text) current-word-parts)) + ;; Continuation of word: insert prefix chord between previous syllable and this one + (begin + ;; Append prefix chord to the LAST syllable (strip trailing space from chord-prefix for infix use) + (unless (string-null? chord-prefix) + (let* ((last-part (car current-word-parts)) + (rest-parts (cdr current-word-parts)) + ;; Remove trailing space from chord-prefix if present + (chord-infix (if (string-suffix? " " chord-prefix) + (substring chord-prefix 0 (- (string-length chord-prefix) 1)) + chord-prefix))) + (set! current-word-parts (cons (string-append last-part chord-infix) rest-parts)))) + ;; Add current syllable + (set! current-word-parts (cons syl-text current-word-parts))))) + + ;; Always collect suffix chords (even from extenders), they'll be output at word end + (unless (string-null? chord-suffix) + (set! pending-word-suffix-chords (cons chord-suffix pending-word-suffix-chords))) + + ;; Complete word only if: no hyphen AND syllable has text (not an extender) + (when (and (not has-hyphen) (not (string-null? syl-text))) + (if (null? current-word-parts) + ;; No word parts (shouldn't happen) - just output suffix chords if any + (unless (null? pending-word-suffix-chords) + (set! current-line (cons (string-concatenate (reverse pending-word-suffix-chords)) current-line)) + (set! pending-word-suffix-chords '())) + ;; Normal word completion with all collected suffix chords + (let ((word-with-suffix + (if (null? pending-word-suffix-chords) + (string-concatenate (reverse current-word-parts)) + (string-append + (string-concatenate (reverse current-word-parts)) + (string-concatenate (reverse pending-word-suffix-chords)))))) + (set! current-line (cons word-with-suffix current-line)) + (set! current-word-parts '()) + (set! pending-word-suffix-chords '())))) + (for-each + (lambda (inline-text) + (set! current-line (cons (caddr inline-text) current-line))) + after-texts) + + ;; If break here, complete line (word parts continue on next line) + (if break-here + (begin + (set! lines (cons (reverse current-line) lines)) + (set! current-line '()) + (process-syllables rest-syls (+ syl-idx 1) (cdr breaks-left) new-inlines-left next-line-chords)) + (process-syllables rest-syls (+ syl-idx 1) breaks-left new-inlines-left '()))))) + + ;; Format all lines and normalize multiple spaces + (string-join + (map (lambda (line-words) + (let ((line (string-join line-words " "))) + (normalize-spaces line))) + (reverse lines)) + "\n")))) + +#(define (map-chords-to-syllables chords syllables) + "For each chord, find the nearest following syllable. + If no following syllable within tolerance, use the last preceding syllable. + Returns list of (chord-moment chord-name syllable-index)" + (let ((tolerance (ly:make-moment 1/4))) + (filter-map + (lambda (chord-entry) + (let* ((chord-moment (car chord-entry)) + (chord-name (cadr chord-entry)) + ;; Find syllables that start AT or AFTER this chord (within tolerance) + (candidate-syllables-forward + (filter-map + (lambda (syl-entry syl-idx) + (let* ((syl-moment (car syl-entry)) + (diff (ly:moment-sub syl-moment chord-moment))) + ;; Syllable must start at or after chord, within tolerance + (if (and (not (ly:moment= 0 + (ly:moment<=? diff tolerance)) + (list diff syl-idx) + #f))) + syllables + (iota (length syllables))))) ; syllable indices + + ;; If no forward match, try to find the last syllable BEFORE the chord + (if (not (null? candidate-syllables-forward)) + ;; Pick the closest following syllable (smallest diff) + (let* ((sorted (sort candidate-syllables-forward (lambda (a b) (ly:moment 0) + (if (ly:moment= 0) + ;; and within tolerance + (let ((valid (and (not (ly:moment= 0 + (ly:moment<=? diff tolerance)))) + (if (and valid + (or (not best-diff) + (ly:moment chordpro-current-verse-index 0)) + (chordpro-write-from-engraver-data chordpro-current-verse-index) + (set! chordpro-file-written #t)) + empty-stencil))))) diff --git a/private_includes/base/verses_with_chords.ily b/private_includes/base/verses_with_chords.ily index c516b75..78b5919 100644 --- a/private_includes/base/verses_with_chords.ily +++ b/private_includes/base/verses_with_chords.ily @@ -379,6 +379,8 @@ Chord_lyrics_spacing_engraver = \override SpacingSpanner.spacing-increment = 0 % \override SpacingSpanner.packed-spacing = ##t \consists \Chord_lyrics_spacing_engraver + % ChordPro engraver in Score context to collect all data + \consists \ChordPro_score_collector \remove Bar_number_engraver \remove Mark_engraver \remove Jump_engraver diff --git a/public_includes/layout_bottom.ily b/public_includes/layout_bottom.ily index 4681a3c..5bbc8ac 100644 --- a/public_includes/layout_bottom.ily +++ b/public_includes/layout_bottom.ily @@ -39,6 +39,20 @@ TEXT = \markuplist { TEXT_PAGES (list TEXT)))) +%% Add invisible ChordPro write trigger to last TEXT_PAGES markuplist +#(when (and (defined? 'chordpro-export-enabled) chordpro-export-enabled (pair? TEXT_PAGES)) + (let* ((last-index (- (length TEXT_PAGES) 1)) + (last-page (list-ref TEXT_PAGES last-index)) + (modified-last-page #{ + \markuplist { + #last-page + \chordpro-delayed-write + } + #})) + (set! TEXT_PAGES + (append (list-head TEXT_PAGES last-index) + (list modified-last-page))))) + #(define (add-text-pages text-pages) (if (pair? text-pages) (begin @@ -55,12 +69,34 @@ TEXT = \markuplist { (if header (set! $defaultheader header)) (if paper (set! $defaultpaper paper)) ) + + ;; ChordPro export: Store filename and extract metadata from basicSongInfo FIRST + (when (and (defined? 'chordpro-export-enabled) chordpro-export-enabled) + ;; Use ly:parser-output-name which returns the output basename + ;; This will write relative to current working directory (same as PDF) + (let ((output-name (ly:parser-output-name))) + (set! chordpro-current-filename output-name)) + + ;; Try to extract metadata from basicSongInfo \header block + (when (defined? 'basicSongInfo) + (let* ((header-alist (ly:module->alist basicSongInfo)) + (title (assoc-ref header-alist 'title)) + (authors (assoc-ref header-alist 'authors))) + (when title + (set! chordpro-header-title + (if (markup? title) + (markup->string title) + (if (string? title) title "Untitled")))) + (when authors + (set! chordpro-header-authors authors))))) + (add-score #{ \score { \MUSIC \layout { \LAYOUT } }#}) (add-text-pages TEXT_PAGES) + (add-score #{ \score { \unfoldRepeats { \MUSIC \INLINESCOREMUSIC } @@ -75,4 +111,4 @@ TEXT = \markuplist { } } }#}) -)) \ No newline at end of file +)) diff --git a/public_includes/pool_bottom.ily b/public_includes/pool_bottom.ily index 13010cb..90f2f89 100644 --- a/public_includes/pool_bottom.ily +++ b/public_includes/pool_bottom.ily @@ -4,4 +4,4 @@ HEADER = \bookpart { \basicSongInfo } } -\include #(if noDefaultOutput "../private_includes/void.ily" "layout_bottom.ily") \ No newline at end of file +\include #(if noDefaultOutput "../private_includes/void.ily" "layout_bottom.ily")