%%% 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) (stringstring (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))))))