From eca352b6d09e409a7b6647e0da592295975cdece Mon Sep 17 00:00:00 2001 From: tux Date: Wed, 22 Nov 2023 15:13:41 +0100 Subject: [PATCH] use \write-toc-csv in a markup to generate a toc.csv --- footer_with_songinfo.ly | 55 +++++++-------- toc_include.ly | 151 ++++++++++++++++++++++++++++++++++++---- 2 files changed, 163 insertions(+), 43 deletions(-) diff --git a/footer_with_songinfo.ly b/footer_with_songinfo.ly index b3967b5..3c8d056 100644 --- a/footer_with_songinfo.ly +++ b/footer_with_songinfo.ly @@ -1,4 +1,27 @@ #(use-modules (ice-9 receive)) +#(define (format-author layout authorId noDetails) + (let ((author (if (defined? 'AUTHOR_DATA) (assoc-ref AUTHOR_DATA authorId) #f))) + (if author + ((ly:output-def-lookup layout 'authorFormat) + noDetails + (assoc-ref author "name") + (assoc-ref author "trail_name") + (assoc-ref author "birth_year") + (assoc-ref author "death_year") + (assoc-ref author "organization") + ) + "unbekannt"))) + +#(define (find-author-ids-by contributionType authors) + (filter-map (lambda (authordata) (if (member contributionType (cdr authordata)) (car authordata) #f)) authors)) + +#(define (find-author-id-with-part-numbers contributionType authors) + (filter-map (lambda (authordata) + (let ((contributionNumbers (filter-map (lambda (contribution) (if (and (list? contribution) (equal? contributionType (car contribution))) (cadr contribution) #f)) (cdr authordata))) + (authorId (car authordata))) + (if (null? contributionNumbers) #f (cons authorId contributionNumbers)) + )) authors)) + #(define-markup-command (print-songinfo layout props) () (define (songinfo-from songId key) (let ((song (if (defined? 'SONG_DATA) (assoc-ref SONG_DATA songId) #f))) @@ -6,39 +29,14 @@ (assoc-ref song key) (ly:warning (ly:format "song with id ~a not found" songId))))) - (define (format-author authorId noDetails) - (let ((author (if (defined? 'AUTHOR_DATA) (assoc-ref AUTHOR_DATA authorId) #f))) - (if author - ((ly:output-def-lookup layout 'authorFormat) - noDetails - (assoc-ref author "name") - (assoc-ref author "trail_name") - (assoc-ref author "birth_year") - (assoc-ref author "death_year") - (assoc-ref author "organization") - ) - "unbekannt"))) - (define (format-poet poetId) - (string-append (ly:output-def-lookup layout 'poetPrefix) " " (format-author poetId #f))) + (string-append (ly:output-def-lookup layout 'poetPrefix) " " (format-author layout poetId #f))) (define (format-composer composerId) - (string-append (ly:output-def-lookup layout 'composerPrefix) " " (format-author composerId #f))) + (string-append (ly:output-def-lookup layout 'composerPrefix) " " (format-author layout composerId #f))) (define (format-poet-and-composer authorId) - (string-append (ly:output-def-lookup layout 'poetAndComposerEqualPrefix) " " (format-author authorId #f))) - - (define (find-author-ids-by contributionType authors) - (filter-map (lambda (authordata) (if (member contributionType (cdr authordata)) (car authordata) #f)) authors) - ) - - (define (find-author-id-with-part-numbers contributionType authors) - (filter-map (lambda (authordata) - (let ((contributionNumbers (filter-map (lambda (contribution) (if (and (list? contribution) (equal? contributionType (car contribution))) (cadr contribution) #f)) (cdr authordata))) - (authorId (car authordata))) - (if (null? contributionNumbers) #f (cons authorId contributionNumbers)) - )) authors) - ) + (string-append (ly:output-def-lookup layout 'poetAndComposerEqualPrefix) " " (format-author layout authorId #f))) (define (numbered-contribution-prefix contributionNumbers prefixLookup) (string-append @@ -53,6 +51,7 @@ (define (format-authors authorIds) (map (lambda (authorId) (format-author + layout authorId (if (member authorId referencedAuthors) #t diff --git a/toc_include.ly b/toc_include.ly index f5ced87..75d798c 100644 --- a/toc_include.ly +++ b/toc_include.ly @@ -219,25 +219,26 @@ indexSection = "Add a section line to the alphabetical index, using @code{indexSectionMarkup} paper variable markup. This can be used to divide the alphabetical index into different sections, for example one section for each first letter." (add-index-item! 'indexSectionMarkup text sorttext)) -#(define (extract-var-from-module module sym) - (let ((variableref (assoc-ref module sym))) - (if variableref (variable-ref variableref) #f)) - ) +#(define (extract-and-check-vars-from-header bookheader varlist) + (let* ((headervars (hash-map->list cons (struct-ref (ly:book-header bookheader) 0))) + (extract-var-and-check (lambda (headervar) + (let* ((variableref (assoc-ref headervars headervar)) + (extracted (if variableref (variable-ref variableref) #f))) + (if (and extracted (not (and (string? extracted) (string-null? extracted)))) extracted #f))))) + (map (lambda (varsymbol) + (cons varsymbol (extract-var-and-check varsymbol)) + ) varlist))) headerToTOC = #(define-music-function (parser location header label) (ly:book? symbol?) (let* ( - (headervars (hash-map->list cons (struct-ref (ly:book-header header) 0))) - (extract-var-and-check (lambda (headervar) (let - ((extracted (extract-var-from-module headervars headervar))) - (if (and extracted (not (string-null? extracted))) extracted #f) - ))) - (title (extract-var-and-check 'title)) - (starttext (extract-var-and-check 'starttext)) - (alttitle (extract-var-and-check 'alttitle)) - (altalttitle (extract-var-and-check 'altalttitle)) - (categorytitle (extract-var-and-check 'categorytitle)) - (categories (extract-var-and-check 'categories)) + (extractedheadervars (extract-and-check-vars-from-header header '(title starttext alttitle altalttitle categorytitle categories))) + (title (assq-ref extractedheadervars 'title)) + (starttext (assq-ref extractedheadervars 'starttext)) + (alttitle (assq-ref extractedheadervars 'alttitle)) + (altalttitle (assq-ref extractedheadervars 'altalttitle)) + (categorytitle (assq-ref extractedheadervars 'categorytitle)) + (categories (assq-ref extractedheadervars 'categories)) (add-to-toc! (lambda (toctitle tocmarkup) (add-index-item! 'indexItemMarkup tocmarkup toctitle label))) ) @@ -247,3 +248,123 @@ headerToTOC = #(define-music-function (parser location header label) (ly:book? s (if altalttitle (add-to-toc! altalttitle (cons (list (cons 'rawtext altalttitle) (cons 'alternative #t)) '()))) (if title (add-to-toc! title (cons (list (cons 'rawtext title)) '())) #{ #}) )) + + +%% https://github.com/NalaGinrut/guile-csv/blob/master/csv/csv.scm + +#(define* (sxml->csv sxml port #:key (delimiter #\,)) + (let* ((d (string delimiter)) + (csv (map (lambda (l) (string-join l d)) sxml))) + (for-each (lambda (l) + (format port "~a~%" l)) + csv))) + +#(define csv-write sxml->csv) + +#(define-markup-command (write-toc-csv layout props) () + (define (csv-escape field) + (if (string-null? field) + field + (string-append + "\"" + (ly:string-substitute "\n" "\\n" + (ly:string-substitute "\"" "\\\"" field)) + "\""))) + (define (format-authors authorIds) + (string-join (map (lambda (authorId) (format-author layout authorId #f)) authorIds) ", ")) + (define cr-regex (ly:make-regex "\r")) + (define crlf-regex (ly:make-regex "\r\n")) + (define para-sep-regex (ly:make-regex "\n[ \t\n]*\n[ \t\n]*")) + (define whitespace-regex (ly:make-regex "[ \t\n]+")) + (define leading-whitespace-regex (ly:make-regex "^[ \t\n]+")) + (define trailing-whitespace-regex (ly:make-regex "[ \t\n]+$")) + (define (cleanup-whitespaces str) + (ly:regex-replace leading-whitespace-regex + (ly:regex-replace trailing-whitespace-regex + (ly:regex-replace whitespace-regex str " ") + "") + "")) + (define (format-info-paragraphs text) + (let* ((para-strings (ly:regex-split + para-sep-regex + (ly:regex-replace + cr-regex + (ly:regex-replace crlf-regex text "\n") + "\n"))) + (para-lines (map cleanup-whitespaces para-strings))) + (string-join para-lines "\n"))) + (define (generate-toc-csv labelPageTable) + (let ((song-lines (map (lambda (song) + (let* ((filename (symbol->string (car song))) + (songvars (cdr song)) + (page-number (number->string (assoc-get (assq-ref songvars 'label) labelPageTable))) + (extractedheadervars (extract-and-check-vars-from-header (assq-ref songvars 'header) + '(title starttext alttitle altalttitle categorytitle categories authors year_text year_melody year_translation year_composition infotext translation pronunciation copyright source))) + (headervar-or-empty (lambda (varsym) + (let ((extracted (assq-ref extractedheadervars varsym))) + (if extracted extracted "")))) + (authors (assq-ref extractedheadervars 'authors)) + (poetIds (find-author-ids-by 'text authors)) + (translatorIds (find-author-ids-by 'translation authors)) + (versePoetData (find-author-id-with-part-numbers 'verse authors)) + (composerIds (find-author-ids-by 'melody authors)) + (verseComposerData (find-author-id-with-part-numbers 'meloverse authors)) + (voiceComposerData (find-author-id-with-part-numbers 'voice authors)) + (compositionIds (find-author-ids-by 'composition authors)) + (bridgeIds (find-author-ids-by 'bridge authors)) + (interludeIds (find-author-ids-by 'interlude authors))) + (map csv-escape + (list + filename + page-number + (headervar-or-empty 'title) + (headervar-or-empty 'starttext) + (headervar-or-empty 'alttitle) + (headervar-or-empty 'altalttitle) + (headervar-or-empty 'categorytitle) + (headervar-or-empty 'categories) + (format-authors (append poetIds (map car versePoetData))) + (format-authors translatorIds) + (format-authors (append composerIds compositionIds bridgeIds interludeIds (map car voiceComposerData) (map car verseComposerData))) + (headervar-or-empty 'year_text) + (headervar-or-empty 'year_melody) + (headervar-or-empty 'year_translation) + (headervar-or-empty 'year_composition) + (headervar-or-empty 'copyright) + (headervar-or-empty 'source) + (format-info-paragraphs (headervar-or-empty 'infotext)) + (format-info-paragraphs (headervar-or-empty 'translation)) + (format-info-paragraphs (headervar-or-empty 'pronunciation)) + )))) + (alist-delete 'imagePage (alist-delete 'emptyPage song-list))))) + (call-with-output-file "toc.csv" + (lambda (port) + (csv-write (cons '( + "filename" + "page-number" + "title" + "starttext" + "alttitle" + "altalttitle" + "categorytitle" + "categories" + "poets" + "translators" + "composers" + "year_text" + "year_melody" + "year_translation" + "year_composition" + "copyright" + "source" + "infotext" + "translation" + "pronunciation" + ) song-lines) port)) + ))) + ; we use a delayed stencil to have all the page references available + (ly:make-stencil + `(delay-stencil-evaluation + ,(delay (let* ((table (ly:output-def-lookup layout 'label-page-table))) + (generate-toc-csv (if (list? table) table '())) + empty-stencil)))))