414 lines
20 KiB
LilyPond
414 lines
20 KiB
LilyPond
%%% Extrahiert Informationen aus einem ly:music-Objekt und liefert eine alist
|
|
%%% mit String-Werten zurueck (z.B. ((time . "4/4") (key . "d minor"))).
|
|
%%% Benoetigt LilyPond >= 2.26.
|
|
|
|
%% note-name->lily-string liegt im Modul (lily display-lily).
|
|
#(use-modules (lily display-lily))
|
|
|
|
#(begin
|
|
|
|
;; --- Taktangabe --------------------------------------------------------
|
|
|
|
;; Numerator einer Taktangabe kann eine Zahl oder eine Liste sein.
|
|
(define (numerator->string num)
|
|
(if (list? num)
|
|
(string-join (map number->string num) "+")
|
|
(number->string num)))
|
|
|
|
;; Ein einzelner Bruch ist ein Paar (numerator . denominator), der
|
|
;; Numerator eine Zahl oder eine Liste (z.B. 3+3/8).
|
|
(define (fraction->string frac)
|
|
(string-append (numerator->string (car frac)) "/"
|
|
(number->string (cdr frac))))
|
|
|
|
;; Liefert die Taktangabe als String (z.B. "4/4", "3+3/8" oder
|
|
;; "3+3/8 + 2/8") oder #f. time-signature ist ein Bruch oder bei
|
|
;; zusammengesetzten Taktarten (\timeAbbrev, \compoundMeter) eine
|
|
;; Liste von Bruechen.
|
|
(define (time-music->string m)
|
|
(let ((ts (ly:music-property m 'time-signature)))
|
|
(and (pair? ts)
|
|
(if (number? (cdr ts))
|
|
(fraction->string ts)
|
|
(string-join (map fraction->string ts) " + ")))))
|
|
|
|
;; --- Tempo ---------------------------------------------------------------
|
|
|
|
;; Liefert die Tempoangabe als String (z.B. "4 = 130", "4. = 60-70",
|
|
;; "Allegro" oder "Allegro (4 = 130)") oder #f.
|
|
(define (tempo-music->string m)
|
|
(let* ((unit (ly:music-property m 'tempo-unit))
|
|
(count (ly:music-property m 'metronome-count))
|
|
(text (ly:music-property m 'text))
|
|
(unit-s (and (ly:duration? unit)
|
|
(string-append
|
|
(number->string (expt 2 (ly:duration-log unit)))
|
|
(make-string (ly:duration-dot-count unit) #\.))))
|
|
(count-s (cond ((number? count) (number->string count))
|
|
((pair? count) (ly:format "~a-~a" (car count) (cdr count)))
|
|
(else #f)))
|
|
(metronome-s (and unit-s count-s (string-append unit-s " = " count-s)))
|
|
(text-s (and (markup? text) (markup->string text))))
|
|
(cond
|
|
((and text-s metronome-s) (string-append text-s " (" metronome-s ")"))
|
|
(metronome-s metronome-s)
|
|
(text-s text-s)
|
|
(else #f))))
|
|
|
|
;; --- Tonart ------------------------------------------------------------
|
|
|
|
;; Liefert die Tonart als String (z.B. "d minor" oder "c major") oder #f.
|
|
;; Vorgehen wie in LilyPonds eigenem \displayMusic (define-music-display-
|
|
;; methods.scm): pitch-alist nach c zuruecktransponieren und mit den
|
|
;; bekannten Modus-Definitionen vergleichen. note-name->lily-string liefert
|
|
;; den Grundton in der aktuell eingestellten Notensprache.
|
|
(define (key-music->string m)
|
|
(let ((tonic (ly:music-property m 'tonic))
|
|
(alist (ly:music-property m 'pitch-alist)))
|
|
(and (ly:pitch? tonic) (pair? alist)
|
|
(let* ((c-alist (ly:transpose-key-alist alist (- tonic)))
|
|
(mode (any (lambda (mode)
|
|
(and (equal? (ly:parser-lookup mode) c-alist)
|
|
(symbol->string mode)))
|
|
'(major minor))))
|
|
(and mode
|
|
(string-append (symbol->string (note-name->lily-string tonic))
|
|
" " mode))))))
|
|
|
|
;; --- Header-Metadaten ----------------------------------------------------
|
|
|
|
;; Header-Felder, die eigentlich Layoutsachen sind (gehoerten nach paper)
|
|
;; und deshalb nicht mit exportiert werden.
|
|
(define ignored-header-fields
|
|
'(titlesize titletopspace tagline between-poet-and-composer-markup))
|
|
|
|
;; categories ist im Header ein String mit Leerzeichen ("trist satz")
|
|
;; und wird als Liste von Woertern exportiert.
|
|
(define (header-value key value)
|
|
(if (and (eq? key 'categories) (string? value))
|
|
(string-tokenize value)
|
|
value))
|
|
|
|
;; Nimmt einen Bookpart entgegen (wie HEADER aus pool_bottom.ily) und
|
|
;; liefert dessen Header-Felder als alist, z.B.
|
|
;; ((title . "Ako umram") (authors . (("..." text melody))) ...).
|
|
;; Die Werte bleiben unveraendert, wie sie im \header definiert wurden
|
|
;; (Strings, Listen, Markups ...).
|
|
(define (bookpart->header-alist bookpart)
|
|
(let ((header (ly:book-header bookpart)))
|
|
(if (module? header)
|
|
(sort
|
|
(filter-map (lambda (entry)
|
|
(and (variable-bound? (cdr entry))
|
|
(not (memq (car entry) ignored-header-fields))
|
|
(cons (car entry)
|
|
(header-value (car entry)
|
|
(variable-ref (cdr entry))))))
|
|
(module-map cons header))
|
|
(lambda (a b)
|
|
(string<? (symbol->string (car a))
|
|
(symbol->string (car b)))))
|
|
'())))
|
|
|
|
;; --- Lyrics --------------------------------------------------------------
|
|
|
|
;; Silbentext (String oder Markup) als String. Eine Tilde verbindet als
|
|
;; Lyric-Bindebogen zwei Woerter auf einer Note und wird zum Leerzeichen.
|
|
(define (syllable->string text)
|
|
(let ((s (cond ((string? text) text)
|
|
((markup? text) (markup->string text))
|
|
(else ""))))
|
|
(string-map (lambda (c) (if (char=? c #\~) #\space c)) s)))
|
|
|
|
;; Stanza-Beschriftung, wie sie gedruckt wuerde; vgl. handle-stanza-numbers
|
|
;; bzw. refMarkupFormatter/bridgeMarkupFormatter in
|
|
;; basic_format_and_style_settings.ily. text ist ein direkt per
|
|
;; \set stanza = "..." gesetzter Wert und gewinnt.
|
|
(define (stanza-label type numbers text)
|
|
(define (joined-numbers)
|
|
(string-join (map (lambda (n) (ly:format "~a" n)) numbers) ", "))
|
|
(define (formatted plain with-numbers)
|
|
(if (null? numbers)
|
|
(ly:parser-lookup plain)
|
|
(ly:format (ly:parser-lookup with-numbers) (joined-numbers))))
|
|
(cond
|
|
(text text)
|
|
((eq? type 'ref) (formatted 'refString 'refStringWithNumbers))
|
|
((eq? type 'bridge) (formatted 'bridgeString 'bridgeStringWithNumbers))
|
|
((pair? numbers)
|
|
(string-join
|
|
(map (lambda (n) (format #f (ly:parser-lookup 'stanzaFormat) n)) numbers)
|
|
", "))
|
|
(else "")))
|
|
|
|
;; Wandelt ein Lyrics-Music-Objekt (eine Zeile aus \addlyrics bzw. das
|
|
;; Argument von \chordlyrics) in eine Liste von Eintraegen der Form
|
|
;; (marked? nummern . ((stanza . "1.") (type . verse) (text . "Auf die ...")))
|
|
;; Silben werden an HyphenEvents wieder zu Woertern zusammengesetzt.
|
|
;; Strophengrenzen ergeben sich aus den StanzaNumber-Overrides von
|
|
;; #(stanza n), \ref und \bridge sowie aus \set stanza = "...".
|
|
;; marked? ist #f fuer Fortsetzungsfragmente: Abschnitte ohne Marker oder
|
|
;; mit dem Zeilenumbruch-Marker \set stanza = "-" (right-/leftHyphen).
|
|
;; \set stanza mit Markup-Wert (Wiederholungszeichen, "D.S." usw.) ist
|
|
;; reine Dekoration mitten im Vers und beginnt keine neue Strophe.
|
|
(define (lyric-line->stanzas lyrics)
|
|
(let ((stanzas '()) ; fertige Eintraege, rueckwaerts
|
|
(words '()) ; fertige Woerter der aktuellen Strophe, rueckwaerts
|
|
(word "") ; offene Silbenkette
|
|
(type #f) ; 'verse / 'ref / 'bridge
|
|
(numbers '()) ; Strophennummern
|
|
(set-label #f)) ; direkt gesetztes \set stanza = "..."
|
|
(define (flush-word!)
|
|
(unless (string-null? word)
|
|
(set! words (cons word words))
|
|
(set! word "")))
|
|
(define (flush-stanza!)
|
|
(flush-word!)
|
|
(when (or type set-label (pair? words))
|
|
(set! stanzas
|
|
(cons (cons* (if (or type (and set-label (not (string=? set-label "-")))) #t #f)
|
|
numbers
|
|
(list (cons 'stanza (stanza-label type numbers set-label))
|
|
(cons 'type (or type 'verse))
|
|
(cons 'text (string-join (reverse words) " "))))
|
|
stanzas))
|
|
(set! words '())
|
|
(set! type #f)
|
|
(set! numbers '())
|
|
(set! set-label #f)))
|
|
;; Ein neuer Marker beendet die laufende Strophe, sobald schon Text da ist.
|
|
(define (marker!)
|
|
(when (or (pair? words) (not (string-null? word)))
|
|
(flush-stanza!)))
|
|
(define (handle-lyric-event m)
|
|
(let ((s (syllable->string (ly:music-property m 'text)))
|
|
(hyphen? (any (lambda (a)
|
|
(eq? (ly:music-property a 'name) 'HyphenEvent))
|
|
(ly:music-property m 'articulations '()))))
|
|
(if (string-null? (string-trim-both s))
|
|
(flush-word!) ; "_"-Skip kommt als " " an und beendet nur das Wort
|
|
(begin
|
|
(set! word (string-append word s))
|
|
(unless hyphen? (flush-word!))))))
|
|
(define (handle-override m)
|
|
(when (eq? (ly:music-property m 'symbol) 'StanzaNumber)
|
|
(let ((path (ly:music-property m 'grob-property-path))
|
|
(value (ly:music-property m 'grob-value)))
|
|
(cond
|
|
((equal? path '(details custom-stanza-type))
|
|
(marker!)
|
|
(set! type value))
|
|
((equal? path '(details custom-stanza-numbers))
|
|
(marker!)
|
|
(set! numbers (if (list? value) value (list value))))))))
|
|
(define (handle-set m)
|
|
(let ((value (ly:music-property m 'value)))
|
|
;; Nur String-Werte; Markups (Wiederholungszeichen etc.) sind
|
|
;; Dekoration mitten im Vers und keine Strophengrenze.
|
|
(when (and (eq? (ly:music-property m 'symbol) 'stanza)
|
|
(string? value))
|
|
(marker!)
|
|
(set! set-label value))))
|
|
(define (walk m)
|
|
(case (ly:music-property m 'name)
|
|
((LyricEvent) (handle-lyric-event m))
|
|
((OverrideProperty) (handle-override m))
|
|
((PropertySet) (handle-set m))
|
|
(else
|
|
(let ((element (ly:music-property m 'element)))
|
|
(if (ly:music? element) (walk element))
|
|
(for-each (lambda (e) (if (ly:music? e) (walk e)))
|
|
(ly:music-property m 'elements))))))
|
|
(walk lyrics)
|
|
(flush-stanza!)
|
|
(merge-reprinted (reverse stanzas))))
|
|
|
|
;; Beim Zeilenumbruch im Notenbild wird die Strophennummer manchmal erneut
|
|
;; gedruckt (z.B. \firstVerseB #(stanza 1) \firstVerseC). Ein Marker
|
|
;; direkt nach einer Strophe mit gleicher Kennung oder deren
|
|
;; Nummern-Obermenge (#(stanza 2 3) nach Strophe 2) setzt diese fort,
|
|
;; statt eine neue Strophe zu beginnen.
|
|
(define (merge-reprinted entries)
|
|
(let loop ((remaining entries) (acc '()))
|
|
(if (null? remaining)
|
|
(reverse acc)
|
|
(let ((entry (car remaining)))
|
|
(if (and (pair? acc)
|
|
(car entry) ; aktueller Eintrag markiert
|
|
(car (car acc)) ; vorheriger Eintrag markiert
|
|
(let* ((prev (car acc))
|
|
(prev-alist (cddr prev))
|
|
(alist (cddr entry))
|
|
(prev-numbers (cadr prev))
|
|
(prev-label (assq-ref prev-alist 'stanza)))
|
|
(or (and (not (string-null? prev-label))
|
|
(string=? prev-label (assq-ref alist 'stanza)))
|
|
(and (eq? (assq-ref prev-alist 'type)
|
|
(assq-ref alist 'type))
|
|
(pair? prev-numbers)
|
|
(every (lambda (n) (member n (cadr entry)))
|
|
prev-numbers)))))
|
|
(begin
|
|
(append-fragment-text! (cddr (car acc)) (cddr entry))
|
|
(loop (cdr remaining) acc))
|
|
(loop (cdr remaining) (cons entry acc)))))))
|
|
|
|
;; Haengt den Text eines Fortsetzungsfragments an eine Strophe an.
|
|
(define (append-fragment-text! target fragment)
|
|
(let ((target-cell (assq 'text target))
|
|
(fragment-text (assq-ref fragment 'text)))
|
|
(unless (string-null? fragment-text)
|
|
(set-cdr! target-cell
|
|
(if (string-null? (cdr target-cell))
|
|
fragment-text
|
|
(string-append (cdr target-cell) " " fragment-text))))))
|
|
|
|
;; Fuegt die Strophen-Eintraege mehrerer Lyric-Zeilen (Ergebnisse von
|
|
;; lyric-line->stanzas) zu einer flachen Strophenliste zusammen. Manche
|
|
;; Lieder verteilen eine Strophe auf mehrere Zeilen unter den Noten
|
|
;; (Fragmente mit \set stanza = "-" bzw. ohne Marker): Fortsetzungen
|
|
;; werden innerhalb einer Zeile an die vorhergehende markierte Strophe
|
|
;; angehaengt; Zeilen ganz ohne markierte Strophen positionsweise an die
|
|
;; markierten Strophen der letzten Zeile, die welche hatte.
|
|
(define (merge-lyric-lines lines)
|
|
(let ((result '()) ; fertige Strophen-alists, rueckwaerts
|
|
(last-marked '())) ; markierte alists der letzten markierten Zeile
|
|
(for-each
|
|
(lambda (line)
|
|
(let ((line-marked (filter-map (lambda (e) (and (car e) (cddr e))) line)))
|
|
(if (and (null? line-marked) (pair? last-marked))
|
|
;; Zeile nur aus Fortsetzungen: k-tes Fragment an k-te
|
|
;; markierte Strophe der Vorzeile, Ueberzaehlige an deren letzte.
|
|
(let loop ((entries line) (targets last-marked))
|
|
(when (pair? entries)
|
|
(append-fragment-text! (car targets) (cddar entries))
|
|
(loop (cdr entries)
|
|
(if (null? (cdr targets)) targets (cdr targets)))))
|
|
;; Zeile mit markierten Strophen (oder erste Zeile ueberhaupt):
|
|
;; Fortsetzungen an die vorhergehende Strophe der Zeile.
|
|
(begin
|
|
(let loop ((entries line)
|
|
(prev (if (pair? last-marked) (last last-marked) #f)))
|
|
(when (pair? entries)
|
|
(let ((marked? (caar entries))
|
|
(stanza-alist (cddar entries)))
|
|
(if (or marked? (not prev))
|
|
(begin
|
|
(set! result (cons stanza-alist result))
|
|
(loop (cdr entries) stanza-alist))
|
|
(begin
|
|
(append-fragment-text! prev stanza-alist)
|
|
(loop (cdr entries) prev))))))
|
|
(when (pair? line-marked)
|
|
(set! last-marked line-marked))))))
|
|
lines)
|
|
(reverse result)))
|
|
|
|
;; Liefert die Lyrics-Zeilen (Music) der ersten Stimme mit Lyrics.
|
|
;; \addlyrics und \lyricsto erzeugen LyricCombineMusic mit dem Namen der
|
|
;; zugehoerigen Stimme in associated-context; Zeilen weiterer Stimmen
|
|
;; (z.B. Zweitstimmen-Text) werden ignoriert.
|
|
(define (first-voice-lyrics music)
|
|
(let* ((combines (extract-named-music music 'LyricCombineMusic))
|
|
(first-ctx (and (pair? combines)
|
|
(ly:music-property (car combines) 'associated-context))))
|
|
(map (lambda (c) (ly:music-property c 'element))
|
|
(filter (lambda (c)
|
|
(equal? (ly:music-property c 'associated-context) first-ctx))
|
|
combines))))
|
|
|
|
;; Ist thing ein Markup-Aufruf des Kommandos mit diesem Namen?
|
|
(define (markup-command? thing name)
|
|
(and (pair? thing)
|
|
(procedure? (car thing))
|
|
(eq? (procedure-name (car thing)) name)))
|
|
|
|
;; Sammelt die Lyrics-Music-Argumente aller \chordlyrics/\nochordlyrics aus
|
|
;; den TEXT_PAGES-Markuplisten. \keep-with-tag/\remove-with-tag werden dabei
|
|
;; wie bei der Markup-Interpretation auf die Music angewendet.
|
|
(define (text-pages-lyric-musics text-pages)
|
|
(define (as-list tags) (if (list? tags) tags (list tags)))
|
|
(define (apply-tag-filters music keep-sets remove-tags)
|
|
(let ((filtered (fold
|
|
(lambda (tags m)
|
|
(music-filter (tags-keep-predicate tags) m))
|
|
(ly:music-deep-copy music)
|
|
keep-sets)))
|
|
(if (pair? remove-tags)
|
|
(music-filter (tags-remove-predicate remove-tags) filtered)
|
|
filtered)))
|
|
(define (collect thing keep-sets remove-tags)
|
|
(cond
|
|
((or (markup-command? thing 'chordlyrics-markup)
|
|
(markup-command? thing 'nochordlyrics-markup))
|
|
(list (apply-tag-filters (cadr thing) keep-sets remove-tags)))
|
|
((markup-command? thing 'keep-with-tag-markup)
|
|
(collect (caddr thing)
|
|
(cons (as-list (cadr thing)) keep-sets)
|
|
remove-tags))
|
|
((markup-command? thing 'remove-with-tag-markup)
|
|
(collect (caddr thing)
|
|
keep-sets
|
|
(append (as-list (cadr thing)) remove-tags)))
|
|
((pair? thing)
|
|
(append (collect (car thing) keep-sets remove-tags)
|
|
(collect (cdr thing) keep-sets remove-tags)))
|
|
(else '())))
|
|
(append-map (lambda (page) (collect page '() '())) text-pages))
|
|
|
|
;; Fuegt Musik- und Textseiten-Strophen zusammen: gleiche stanza-Kennungen
|
|
;; nur einmal, wobei die Fassung aus den Textseiten die unter den Noten
|
|
;; ersetzt (dort steht meist die vollstaendige Fassung).
|
|
(define (merge-stanza-lists music-stanzas text-stanzas)
|
|
(let loop ((merged music-stanzas) (remaining text-stanzas))
|
|
(if (null? remaining)
|
|
merged
|
|
(let* ((entry (car remaining))
|
|
(key (assq-ref entry 'stanza))
|
|
(found (and (not (string-null? key))
|
|
(not (string=? key "-"))
|
|
(find (lambda (e) (equal? (assq-ref e 'stanza) key))
|
|
merged))))
|
|
(loop (if found
|
|
(map (lambda (e) (if (eq? e found) entry e)) merged)
|
|
(append merged (list entry)))
|
|
(cdr remaining))))))
|
|
|
|
;; Extrahiert alle Strophen/Refrain/Bridge-Texte eines Liedes: die Strophen
|
|
;; unter den Noten aus music (nur erste Stimme), die Textstrophen aus den
|
|
;; \chordlyrics der text-pages.
|
|
(define (extract-lyrics music text-pages)
|
|
(merge-stanza-lists
|
|
(merge-lyric-lines (map lyric-line->stanzas (first-voice-lyrics music)))
|
|
(append-map (lambda (m) (merge-lyric-lines (list (lyric-line->stanzas m))))
|
|
(text-pages-lyric-musics text-pages))))
|
|
|
|
;; --- Hauptfunktion -----------------------------------------------------
|
|
|
|
;; Liefert das erste Music-Objekt mit gegebenem Namen (oder #f).
|
|
(define (first-named-music music music-name)
|
|
(let ((matches (extract-named-music music music-name)))
|
|
(and (pair? matches) (car matches))))
|
|
|
|
;; Nimmt ly:music entgegen und liefert eine alist mit String-Werten.
|
|
(define (music->data-alist music)
|
|
(let* ((time-m (first-named-music
|
|
music '(TimeSignatureMusic ReferenceTimeSignatureMusic)))
|
|
(key-m (first-named-music music 'KeyChangeEvent))
|
|
(tempo-m (first-named-music music 'TempoChangeEvent))
|
|
(time-s (and time-m (time-music->string time-m)))
|
|
(key-s (and key-m (key-music->string key-m)))
|
|
(tempo-s (and tempo-m (tempo-music->string tempo-m))))
|
|
(append
|
|
(if time-s (list (cons 'time time-s)) '())
|
|
(if key-s (list (cons 'key key-s)) '())
|
|
(if tempo-s (list (cons 'tempo tempo-s)) '()))))
|
|
|
|
(define (extract-song-data header music text-pages)
|
|
(let ((header-alist (bookpart->header-alist header))
|
|
(music-alist (music->data-alist music))
|
|
(lyrics-list (extract-lyrics music text-pages)))
|
|
(append header-alist
|
|
(list (cons 'musical music-alist)
|
|
(cons 'lyrics lyrics-list))))))
|