From a19013964cd253abc475a6f3a228efbd92abc474 Mon Sep 17 00:00:00 2001 From: Christoph Wagner Date: Sat, 11 Jul 2026 20:32:22 +0200 Subject: [PATCH] extract meta data from lilypond compilation * write that as yaml file next to the other outputs * extract lyrics --- private_includes/base/all.ily | 4 +- private_includes/base/data_extractor.ily | 413 ++++++++++++++++++++++ private_includes/base/scm/yaml_parser.scm | 367 ++++++++++++------- private_includes/base/scm/yaml_writer.scm | 162 +++++++++ private_includes/book/book_include.ily | 52 ++- public_includes/layout_bottom.ily | 7 + 6 files changed, 867 insertions(+), 138 deletions(-) create mode 100644 private_includes/base/data_extractor.ily create mode 100644 private_includes/base/scm/yaml_writer.scm diff --git a/private_includes/base/all.ily b/private_includes/base/all.ily index 49cdc4e..30d7617 100644 --- a/private_includes/base/all.ily +++ b/private_includes/base/all.ily @@ -20,7 +20,8 @@ "scm" file-name-separator-string filename ))))) (scm-load "resolve_inherits.scm") - (scm-load "yaml_parser.scm"))) + (scm-load "yaml_parser.scm") + (scm-load "yaml_writer.scm"))) #(define (song-includes-data-path filename) (string-join @@ -39,6 +40,7 @@ \include "title_with_category_images.ily" \include "chord_settings.ily" \include "chordpro.ily" +\include "data_extractor.ily" \include "transposition.ily" \include "markup_tag_groups_hack.ily" \include "verses_with_chords.ily" diff --git a/private_includes/base/data_extractor.ily b/private_includes/base/data_extractor.ily new file mode 100644 index 0000000..42522ed --- /dev/null +++ b/private_includes/base/data_extractor.ily @@ -0,0 +1,413 @@ +%%% 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)))))) diff --git a/private_includes/base/scm/yaml_parser.scm b/private_includes/base/scm/yaml_parser.scm index 420d447..4b159f8 100644 --- a/private_includes/base/scm/yaml_parser.scm +++ b/private_includes/base/scm/yaml_parser.scm @@ -1,154 +1,259 @@ -(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 pretty-print) (srfi srfi-1)) +(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 receive) (srfi srfi-1)) + +;; YAML-Parser: liest eine Teilmenge von YAML (Block-Syntax, keine +;; Flow-Collections, keine Block-Skalare) in verschachtelte +;; alist/list-Strukturen. Gegenstück zu yaml_writer.scm. +;; +;; Ergebnisformat: +;; - Mapping -> alist mit String-Keys, Reihenfolge wie in der Datei +;; - Liste -> Liste (auch als "- key: value"-Inline-Mappings) +;; - Skalare -> String, Zahl, #t/#f, '() (null / {} / []) +;; +;; Skalar-Interpretation: +;; - unquoted und 'single-quoted' Werte werden interpretiert +;; (Zahl, true/false/null). Das Interpretieren von single-quoted +;; Werten ist Kompatibilitätsverhalten zum alten Parser: +;; authors.yml notiert Zahlen als '1898'. +;; - "double-quoted" Werte bleiben immer Strings; \\, \" und \n +;; werden entescaped (so schreibt sie der yaml_writer). +;; - Kommentare (#) werden nur außerhalb von Quotes entfernt und nur, +;; wenn ihnen ein Leerzeichen oder der Zeilenanfang vorausgeht. -;; Hauptparsingfunktion (define (yml-file->scm filename) - ;; Utility: Zeile einlesen - (define (read-lines filename) + ;; --- Zeilen einlesen ------------------------------------------------ + + ;; Anzahl führender Leerzeichen + (define (line-indent line) + (let loop ((i 0)) + (if (and (< i (string-length line)) + (char=? (string-ref line i) #\space)) + (loop (+ i 1)) + i))) + + ;; Liefert Items (indent . inhalt); Leerzeilen, reine Kommentarzeilen + ;; und Dokumentmarker (--- / ...) werden übersprungen. + (define (read-items filename) (call-with-input-file filename (lambda (port) - (let loop ((lines '())) + (let loop ((items '())) (let ((line (read-line port))) (if (eof-object? line) - (reverse lines) - (let ((clean (string-trim line))) - (if (or (string=? clean "---") (string-null? clean)) - (loop lines) ;; Ignoriere "---" oder leere Zeile - (loop (cons line lines)))))))))) + (reverse items) + (let* ((line (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + (content (string-trim-both line))) + (if (or (string-null? content) + (string-prefix? "#" content) + (string=? content "---") + (string=? content "...")) + (loop items) + (loop (cons (cons (line-indent line) content) + items)))))))))) - ;; Einrückung bestimmen (Anzahl Leerzeichen am Anfang) - (define (line-indent line) - (let ((match (string-match "^ *" line))) - (if match - (match:end match) ; Anzahl der Leerzeichen = Position nach Leerzeichen - 0))) ; Falls kein Match → 0 + (define (item-indent item) (car item)) + (define (item-content item) (cdr item)) - ;; Kommentar entfernen - (define (strip-comment line) - (let ((m (string-match "#.*" line))) - (if m - (string-trim-right (string-take line (match:start m))) - line))) + ;; --- Skalare ---------------------------------------------------------- - ;; Hilfsfunktion: Whitespace entfernen - (define (clean-line line) - (string-trim (strip-comment line))) + ;; Position des schließenden Double-Quotes ab start (oder #f); + ;; Backslash escaped das Folgezeichen. + (define (closing-double-quote s start) + (let loop ((i start)) + (cond ((>= i (string-length s)) #f) + ((char=? (string-ref s i) #\\) (loop (+ i 2))) + ((char=? (string-ref s i) #\") i) + (else (loop (+ i 1)))))) - ;; Ist Zeile leer (nach Entfernen von Kommentar & Whitespace)? - (define (blank-or-comment? line) - (string-null? (clean-line line))) + ;; Position des schließenden Single-Quotes ab start (oder #f); + ;; '' ist ein escaptes Quote. + (define (closing-single-quote s start) + (let loop ((i start)) + (cond ((>= i (string-length s)) #f) + ((char=? (string-ref s i) #\') + (if (and (< (+ i 1) (string-length s)) + (char=? (string-ref s (+ i 1)) #\')) + (loop (+ i 2)) + i)) + (else (loop (+ i 1)))))) - ;; Skalare Werte interpretieren + ;; \\ -> \, \" -> ", \n -> Zeilenumbruch + (define (unescape-double s) + (let loop ((chars (string->list s)) (acc '())) + (cond ((null? chars) (list->string (reverse acc))) + ((and (char=? (car chars) #\\) (pair? (cdr chars))) + (loop (cddr chars) + (cons (if (char=? (cadr chars) #\n) + #\newline + (cadr chars)) + acc))) + (else (loop (cdr chars) (cons (car chars) acc)))))) + + ;; '' -> ' + (define (unescape-single s) + (regexp-substitute/global #f "''" s 'pre "'" 'post)) + + ;; Kommentar in einem unquoted Wert entfernen: + ;; # zählt nur am Anfang oder nach Leerzeichen + (define (strip-plain-comment s) + (let loop ((i 0)) + (cond ((>= i (string-length s)) s) + ((and (char=? (string-ref s i) #\#) + (or (zero? i) + (char-whitespace? (string-ref s (- i 1))))) + (string-take s i)) + (else (loop (+ i 1)))))) + + ;; Unquoted/single-quoted Werte interpretieren + (define (interpret-plain s) + (cond + ((member s '("{}" "[]" "null")) '()) + ((string=? s "true") #t) + ((string=? s "false") #f) + ((string-match "^-?[0-9]+(\\.[0-9]+)?$" s) (string->number s)) + (else s))) + + ;; Skalar parsen; Rest hinter einem schließenden Quote wird ignoriert + ;; (darf nur ein Kommentar sein) (define (parse-scalar str) - (define (strip-quotes s) + (let ((s (string-trim-both str))) (cond - ((and (string-prefix? "\"" s) (string-suffix? "\"" s)) - (string-drop-right (string-drop s 1) 1)) - ((and (string-prefix? "'" s) (string-suffix? "'" s)) - (string-drop-right (string-drop s 1) 1)) - (else s))) - (let ((s (strip-quotes (string-trim str)))) + ((string-null? s) "") + ((char=? (string-ref s 0) #\") + (let ((end (closing-double-quote s 1))) + (if end + (unescape-double (substring s 1 end)) + (string-trim-right (strip-plain-comment s))))) + ((char=? (string-ref s 0) #\') + (let ((end (closing-single-quote s 1))) + (if end + (interpret-plain (unescape-single (substring s 1 end))) + (string-trim-right (strip-plain-comment s))))) + (else + (interpret-plain (string-trim-right (strip-plain-comment s))))))) + + ;; --- Struktur ---------------------------------------------------------- + + ;; Erste Key-Trennstelle: ":" am Zeilenende oder gefolgt von Leerzeichen. + ;; Beginnt die Zeile mit einem gequoteten Key (oder Skalar), zaehlt ein + ;; ":" innerhalb der Quotes nicht als Trennstelle. + (define (key-split-index s) + (let ((start (if (string-null? s) + 0 + (case (string-ref s 0) + ((#\") (let ((end (closing-double-quote s 1))) + (if end (+ end 1) 0))) + ((#\') (let ((end (closing-single-quote s 1))) + (if end (+ end 1) 0))) + (else 0))))) + (let loop ((i start)) + (cond ((>= i (string-length s)) #f) + ((and (char=? (string-ref s i) #\:) + (or (= i (- (string-length s) 1)) + (char=? (string-ref s (+ i 1)) #\space))) + i) + (else (loop (+ i 1))))))) + + ;; Key interpretieren: gequotete Keys werden entquotet (Strings bleiben + ;; Strings), unquoted Keys bleiben unveraendert + (define (parse-key s) + (let ((k (string-trim-both s))) (cond - ((string=? s "{}") '()) ;; leere Map - ((string=? s "[]") '()) ;; leere Liste - ((string-match "^[0-9]+$" s) (string->number s)) - ((string=? s "true") #t) - ((string=? s "false") #f) - ((string=? s "null") '()) - (else s)))) + ((string-null? k) k) + ((char=? (string-ref k 0) #\") + (let ((end (closing-double-quote k 1))) + (if end (unescape-double (substring k 1 end)) k))) + ((char=? (string-ref k 0) #\') + (let ((end (closing-single-quote k 1))) + (if end (unescape-single (substring k 1 end)) k))) + (else k)))) + (define (dash-line? content) + (or (string=? content "-") (string-prefix? "- " content))) - ;; Hilfsfunktion: Zeilen mit gleicher oder höherer Einrückung sammeln - (define (take-indented lines min-indent) - (let loop ((ls lines) (acc '())) - (if (null? ls) - (reverse acc) - (let ((line (car ls))) - (if (or (blank-or-comment? line) - (>= (line-indent line) min-indent)) - (loop (cdr ls) (cons line acc)) - (reverse acc)))))) + ;; Wert-String hinter "key:" bzw. "-": reiner Kommentar zählt als leer + (define (effective-value str) + (let ((s (string-trim-both str))) + (if (string-prefix? "#" s) "" s))) - ;; Hilfsfunktion: N Zeilen überspringen - (define (drop lst n) - (let loop ((l lst) (i n)) - (if (or (zero? i) (null? l)) - l - (loop (cdr l) (- i 1))))) + ;; Einen Block von Items parsen; das erste Item bestimmt die Blockart + (define (parse-block items) + (cond + ((null? items) '()) + ((dash-line? (item-content (car items))) (parse-list items)) + ;; einzelne Zeile ohne Key: Skalar (z.B. eine Datei, die nur {} enthält) + ((and (null? (cdr items)) + (not (key-split-index (item-content (car items))))) + (parse-scalar (item-content (car items)))) + (else (parse-map items)))) - ;; Listenparsing: Liest Zeilen mit `-` als Listeneinträge - (define (parse-list lines current-indent) - (let loop ((ls lines) (result '())) - (if (null? ls) - (reverse result) - (let* ((line (clean-line (car ls)))) - (if (string-match "^-" line) - (let* ((indent (line-indent (car ls))) - (item-str (string-trim (string-drop line 1))) - (next-lines (cdr ls))) - (if (or (null? next-lines) - (> (line-indent (car next-lines)) indent)) - ;; Verschachtelter Inhalt - (let* ((sub (take-indented next-lines (+ indent 2))) - (parsed (if (null? sub) - (parse-scalar item-str) - (parse-lines sub (+ indent 2)))) - (remaining (drop next-lines (length sub)))) - (loop remaining (cons parsed result))) - ;; Einfacher Skalar - (loop next-lines (cons (parse-scalar item-str) result)))) - ;; Nicht mehr Teil der Liste - (reverse result)))))) + ;; Mapping: alle Items auf map-indent sind Keys, tiefer eingerückte + ;; Items gehören zum jeweils vorangehenden Key + (define (parse-map items) + (let ((map-indent (item-indent (car items)))) + (let loop ((items items) (result '())) + (if (null? items) + (reverse result) + (let* ((content (item-content (car items))) + (split (key-split-index content))) + (if (not split) + (begin + (format (current-error-port) + "YAML-Syntaxfehler: Ungültige Zeile: ~a\n" content) + (loop (cdr items) result)) + (let ((key (parse-key (string-take content split))) + (value-str (effective-value + (string-drop content (+ split 1))))) + (if (string-null? value-str) + ;; Wert steht im eingerückten Block darunter + (receive (children rest) + (span (lambda (it) (> (item-indent it) map-indent)) + (cdr items)) + (loop rest + (cons (cons key (parse-block children)) + result))) + (loop (cdr items) + (cons (cons key (parse-scalar value-str)) + result)))))))))) - ;; Hauptparser für Key-Value oder Listen - (define (parse-lines lines current-indent) - (let loop ((ls lines) (result '())) - (if (null? ls) - (reverse result) - (let* ((raw-line (car ls)) - (line (clean-line raw-line))) - (cond - ;; Kommentar oder leere Zeile - ((blank-or-comment? raw-line) - (loop (cdr ls) result)) + ;; Liste: "- wert", "- key: value" (Inline-Mapping) oder "-" mit + ;; eingerücktem Block darunter + (define (parse-list items) + (let ((list-indent (item-indent (car items)))) + (let loop ((items items) (result '())) + (if (null? items) + (reverse result) + (let ((content (item-content (car items)))) + (if (not (dash-line? content)) + (begin + (format (current-error-port) + "YAML-Syntaxfehler: Ungültiges Listenelement: ~a\n" + content) + (loop (cdr items) result)) + (receive (children rest) + (span (lambda (it) (> (item-indent it) list-indent)) + (cdr items)) + (let* ((after-dash (string-drop content 1)) + (inline (effective-value after-dash))) + (cond + ((and (string-null? inline) (null? children)) + (loop rest (cons '() result))) + ((string-null? inline) + (loop rest (cons (parse-block children) result))) + (else + ;; Inline-Inhalt: als synthetisches Item mit der + ;; Spalte des Inhalts vor die Kinder stellen, so + ;; funktioniert auch "- key: value" mit weiteren + ;; Keys auf den Folgezeilen + (let* ((offset (- (string-length content) + (string-length + (string-trim after-dash)))) + (synth (cons (+ list-indent offset) inline))) + (loop rest + (cons (parse-block (cons synth children)) + result))))))))))))) - ;; Liste - ((string-match "^- " line) - (let ((list-lines (take-indented ls current-indent))) - (let ((parsed-list (parse-list list-lines current-indent))) - (loop (drop ls (length list-lines)) - (cons parsed-list result))))) - - ;; Key: Value - ((string-match "^[^:]+:" line) - (let* ((kv (string-split line #\:)) - (key (string-trim (car kv))) - (value-str (string-trim (string-join (cdr kv) ":"))) - (next-lines (cdr ls))) - (if (string-null? value-str) - ;; Wert auf nachfolgender Einrückungsebene - (let* ((sub (take-indented next-lines (+ current-indent 2))) - (parsed (parse-lines sub (+ current-indent 2))) - (remaining (drop next-lines (length sub)))) - (loop remaining - (cons (cons key parsed) result))) - ;; Einfacher Key:Value - (loop next-lines - (cons (cons key (parse-scalar value-str)) result))))) - - ;; Fehlerhafte Zeile - (else - ;; Vermeide Fehlermeldung für Leerzeilen oder leere Objekte - (if (or (string-null? (string-trim line)) - (member line '("{}" "[]"))) - (loop (cdr ls) result) - (begin - (format (current-error-port) - "Syntaxfehler: Ungültige Zeile: ~a\n" raw-line) - (loop (cdr ls) result)))) - ))))) - - (let ((lines (read-lines filename))) - (parse-lines lines 0))) + (parse-block (read-items filename))) (define (parse-yml-file filename) (resolve-inherits (yml-file->scm filename))) diff --git a/private_includes/base/scm/yaml_writer.scm b/private_includes/base/scm/yaml_writer.scm new file mode 100644 index 0000000..eaf4a60 --- /dev/null +++ b/private_includes/base/scm/yaml_writer.scm @@ -0,0 +1,162 @@ +(use-modules (ice-9 regex) (srfi srfi-1)) + +;; YAML-Writer: Gegenstück zu yaml_parser.scm. +;; Schreibt verschachtelte alist/list-Strukturen als YAML, so dass +;; yml-file->scm sie wieder einlesen kann. +;; +;; Datenmodell (wie vom Parser erzeugt): +;; - Mapping: Liste von Paaren (key . value), key als String oder Symbol +;; - Liste: Liste von beliebigen Werten +;; - Skalare: String, Zahl, #t/#f, '() (leer/null, wird als [] geschrieben) +;; +;; Andere Werte werden vorab automatisch umgewandelt: Markups zu Strings, +;; alles Unbekannte über ~a formatiert (siehe yml-sanitize). + +;; Steuert, ob layout_bottom.ily die Header-Daten des Liedes als +;; YAML-Datei exportiert; aktivierbar per (set! yaml-export-enabled #t) +;; oder durch Definieren der Variable vor dem Laden der Includes. +(define yaml-export-enabled + (if (defined? 'yaml-export-enabled) yaml-export-enabled #f)) + +;; Beliebige Werte in YAML-taugliche Daten umwandeln. +;; (Benötigt die LilyPond-Umgebung für markup? und markup->string.) +(define (yml-sanitize v) + (cond + ((or (string? v) (number? v) (boolean? v) (symbol? v) (null? v)) v) + ((markup? v) (markup->string v)) + ((list? v) (map yml-sanitize v)) + ((pair? v) (cons (yml-sanitize (car v)) (yml-sanitize (cdr v)))) + (else (format #f "~a" v)))) + +(define (scm->yml-string data) + + ;; Ist data ein Mapping (alist)? Nicht-leere Liste, deren Elemente + ;; alle Paare mit String- oder Symbol-Key sind. + ;; Achtung: eine Liste von Listen, deren erste Elemente Strings sind, + ;; ist davon nicht unterscheidbar und wird als Mapping interpretiert. + (define (mapping? data) + (and (pair? data) + (list? data) + (every (lambda (entry) + (and (pair? entry) + (or (string? (car entry)) + (symbol? (car entry))))) + data))) + + (define (scalar? v) + (or (string? v) (symbol? v) (number? v) (boolean? v) (null? v))) + + (define (key->string k) + (if (symbol? k) (symbol->string k) k)) + + ;; Muss der String gequotet werden, damit er beim Einlesen wieder + ;; als derselbe String erkannt wird? + (define (needs-quotes? s) + (or (string-null? s) + (member s '("true" "false" "null" "{}" "[]")) + (string->number s) ;; zahlartig ("1981", "1.", "-5") würde zur Zahl + (string-index s #\#) ;; würde als Kommentar abgeschnitten + (string-index s #\:) ;; würde als Key: Value gelesen + (string-index s #\newline) ;; mehrzeilig + (string-index s #\") + (string-prefix? "-" s) ;; würde als Listenelement gelesen + (string-prefix? "'" s) + (not (string=? s (string-trim-both s))))) ;; führende/folgende Leerzeichen + + ;; Doppelt gequoteter YAML-String; Backslash, Anführungszeichen und + ;; Zeilenumbrüche werden escaped, damit alles auf einer Zeile bleibt. + (define (quote-string s) + (string-append + "\"" + (string-concatenate + (map (lambda (c) + (cond + ((char=? c #\\) "\\\\") + ((char=? c #\") "\\\"") + ((char=? c #\newline) "\\n") + (else (string c)))) + (string->list s))) + "\"")) + + (define (scalar->string v) + (cond + ((eq? v #t) "true") + ((eq? v #f) "false") + ((null? v) "[]") + ((number? v) (number->string v)) + ((symbol? v) (scalar->string (symbol->string v))) + ((string? v) (if (needs-quotes? v) (quote-string v) v)) + (else (error "scm->yml-string: nicht unterstützter Wert" v)))) + + (define (indent-string n) (make-string n #\space)) + + ;; Key ggf. quoten (leere oder zahlartige Keys, Sonderzeichen) + (define (key->yml-string k) + (let ((s (key->string k))) + (if (needs-quotes? s) (quote-string s) s))) + + ;; Doppelte Keys sind in YAML nicht erlaubt: Werte gleicher Keys werden + ;; zu einer Liste zusammengefasst, z.B. authors mit (voice 2) (voice 3) + ;; -> voice: [2, 3]. + (define (merge-duplicate-keys data) + (define (value->list v) + (if (and (list? v) (not (mapping? v))) v (list v))) + (let loop ((entries data) (result '())) + (if (null? entries) + (reverse result) + (let* ((entry (car entries)) + (existing (find (lambda (e) (equal? (car e) (car entry))) + result))) + (if existing + (begin + (set-cdr! existing (append (value->list (cdr existing)) + (value->list (cdr entry)))) + (loop (cdr entries) result)) + (loop (cdr entries) + (cons (cons (car entry) (cdr entry)) result))))))) + + ;; Mapping schreiben: "key: skalar" oder "key:" mit eingerücktem Inhalt + (define (write-mapping data indent port) + (for-each + (lambda (entry) + (let ((key (key->yml-string (car entry))) + (value (cdr entry))) + (if (scalar? value) + (format port "~a~a: ~a\n" + (indent-string indent) key (scalar->string value)) + (begin + (format port "~a~a:\n" (indent-string indent) key) + (write-node value (+ indent 2) port))))) + (merge-duplicate-keys data))) + + ;; Liste schreiben: "- skalar" oder "-" mit eingerücktem Inhalt + ;; (Verschachtelter Inhalt darf NICHT auf der "-"-Zeile beginnen, + ;; weil parse-list den Inhalt der "-"-Zeile verwirft, sobald + ;; eingerückte Folgezeilen existieren.) + (define (write-list data indent port) + (for-each + (lambda (item) + (if (scalar? item) + (format port "~a- ~a\n" + (indent-string indent) (scalar->string item)) + (begin + (format port "~a-\n" (indent-string indent)) + (write-node item (+ indent 2) port)))) + data)) + + (define (write-node data indent port) + (cond + ((mapping? data) (write-mapping data indent port)) + ((and (list? data) (not (null? data))) (write-list data indent port)) + (else (format port "~a~a\n" (indent-string indent) (scalar->string data))))) + + (call-with-output-string + (lambda (port) (write-node (yml-sanitize data) 0 port)))) + +;; Daten als YAML-Datei schreiben +(define (scm->yml-file filename data) + (call-with-output-file filename + (lambda (port) + (display "---\n" port) + (display (scm->yml-string data) port)))) + diff --git a/private_includes/book/book_include.ily b/private_includes/book/book_include.ily index 43f80e2..0d8a722 100644 --- a/private_includes/book/book_include.ily +++ b/private_includes/book/book_include.ily @@ -65,6 +65,26 @@ additionalPageNumbers = display-pages-list ) +% Fuer Zusatzseiten: Label der ersten Seite des zusammenhaengenden +% Zusatzseiten-Blocks, zu dem label gehoert (bestimmt den Buchstaben-Suffix a, b, ...). +#(define (earliest-additional-label label) + (let find-earliest-additional-label + ((rest-additional-page-switch-label-list (member (cons label #t) additional-page-switch-label-list))) + (if (cdadr rest-additional-page-switch-label-list) + (find-earliest-additional-label (cdr rest-additional-page-switch-label-list)) + (caar rest-additional-page-switch-label-list)))) + +% Sichtbare Seitenzahl der Seite mit diesem Label: normalerweise eine Zahl, +% auf Zusatzseiten ein String mit Buchstaben-Suffix (z.B. "12a"); gleiche +% Logik wie custom-page-number unten. +#(define (visible-page-value layout label) + (let ((display-page (assq-ref (build-display-pages-list layout) label))) + (if (assq-ref additional-page-switch-label-list label) + (ly:format "~a~a" display-page + (string (integer->char (+ 97 (- (real-page-number layout label) + (real-page-number layout (earliest-additional-label label))))))) + display-page))) + % TODO: % Eigentlich können wir das direkt in oddFooderMarkup und evenFooterMarkup aufrufen % vermutlich sogar ohne den delay kram. Wir sollten außerdem einfach nur die property @@ -97,12 +117,7 @@ width may require additional tweaking.)" (if (assq-ref additional-page-switch-label-list label) (make-concat-markup (list (number-format number-type display-page) (make-char-markup (+ 97 (- real-current-page (real-page-number layout - (let find-earliest-additional-label - ((rest-additional-page-switch-label-list (member (cons label #t) additional-page-switch-label-list))) - (if (cdadr rest-additional-page-switch-label-list) - (find-earliest-additional-label (cdr rest-additional-page-switch-label-list)) - (caar rest-additional-page-switch-label-list))) - )))))) + (earliest-additional-label label))))))) (number-format number-type (+ display-page (- real-current-page (real-page-number layout label)))) )) (page-stencil (interpret-markup layout props page-markup)) @@ -118,6 +133,31 @@ width may require additional tweaking.)" (make-filled-box-stencil x-ext y-ext)))) +%% Schreibt die Daten aller Lieder des Buchs (extract-song-data, siehe +%% data_extractor.ily) als YAML-Datei: oberster Key contents, darunter eine +%% Liste mit den Lied-Daten, jeweils angereichert um den Key page mit der +%% sichtbaren Seitenzahl des Liedanfangs. Einbinden wie \write-toc-csv in +%% einem Markup des Buchs; wie dort passiert das Schreiben ueber ein +%% delayed stencil, weil die Label->Seiten-Tabelle erst beim Ausgeben des +%% Buchs feststeht. +#(define-markup-command (write-book-yaml layout props filename) (string?) + (ly:make-stencil + `(delay-stencil-evaluation + ,(delay + (begin + (scm->yml-file filename + (list (cons 'contents + (map (lambda (song) + (let ((songvars (cdr song))) + (cons (cons 'page (visible-page-value layout (assq-ref songvars 'label))) + (extract-song-data (assq-ref songvars 'header) + (assq-ref songvars 'music) + (assq-ref songvars 'text-pages))))) + (reverse (alist-delete 'markupPage + (alist-delete 'imagePage + (alist-delete 'emptyPage song-list)))))))) + empty-stencil))))) + includeSong = #(define-void-function (filename) (string?) #{ diff --git a/public_includes/layout_bottom.ily b/public_includes/layout_bottom.ily index 3a4f03a..682a08f 100644 --- a/public_includes/layout_bottom.ily +++ b/public_includes/layout_bottom.ily @@ -72,6 +72,13 @@ TEXT = \markuplist { (if paper (set! $defaultpaper paper)) ) + ;; Meta-Daten des Liedes als YAML neben die Ausgabedatei schreiben + ;; (.yml, landet wie das PDF relativ zum Arbeitsverzeichnis) + (when (and (defined? 'yaml-export-enabled) yaml-export-enabled) + (scm->yml-file + (string-append (ly:parser-output-name) ".yml") + (extract-song-data HEADER MUSIC TEXT_PAGES))) + ;; 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