449 lines
22 KiB
Plaintext
449 lines
22 KiB
Plaintext
% embed all category images in postscript once
|
||
#(define-markup-list-command (embed-category-images layout props)()
|
||
(map (lambda (category)
|
||
(interpret-markup layout props
|
||
(markup #:epsfileembed (category-image-path (symbol->string (car category))))))
|
||
category-names))
|
||
|
||
% print a markup-list in columns
|
||
#(define-markup-list-command (columnlayout layout props cols margin heightpair lines) (integer? number? pair? markup-list?)
|
||
(let create-col-page ((line-width (- (/ (chain-assoc-get 'line-width props
|
||
(ly:output-def-lookup layout 'line-width))
|
||
cols) margin ))
|
||
(cols cols)
|
||
(height (car heightpair))
|
||
(restlines lines))
|
||
(cons
|
||
(interpret-markup layout props
|
||
(make-fill-line-markup
|
||
(map (lambda (foo)
|
||
(make-general-align-markup Y UP (make-override-markup '(baseline-skip . 1) (make-column-markup
|
||
(let add-to-col ((lines restlines) (height-left height))
|
||
(set! restlines lines)
|
||
(if (null? lines)
|
||
'()
|
||
(let* ((line-to-stencil (lambda (line) (interpret-markup layout (cons (list (cons 'line-width line-width) (cons 'baseline-skip 1)) props) (markup line))))
|
||
(stencil-height (lambda (stencil) (interval-length (ly:stencil-extent stencil Y))))
|
||
(linestencil (line-to-stencil (car lines)))
|
||
(current-line-height (stencil-height linestencil))
|
||
(new-height-left (- height-left current-line-height))
|
||
(next-line-height (if (null? (cdr lines)) current-line-height (stencil-height (line-to-stencil (cadr lines)))))
|
||
(no-space-for-next-line (and (< next-line-height current-line-height) (< new-height-left next-line-height)))
|
||
)
|
||
(if (or (< new-height-left 0) no-space-for-next-line)
|
||
'()
|
||
(cons (markup #:stencil linestencil) (add-to-col (cdr lines) new-height-left))))))))))
|
||
(make-list cols))))
|
||
(if (null? restlines)
|
||
(list)
|
||
(create-col-page line-width cols (cdr heightpair) restlines)))))
|
||
|
||
%%%%%%%%%%%%%%%%%%%%%%%
|
||
%%%Funktionen für Inhaltsverzeichnis
|
||
% geklaut von da:
|
||
% http://lsr.dsi.unimi.it/LSR/Snippet?id=763
|
||
|
||
% Usage:
|
||
% - define and index item with \indexItem $sortstring $markup
|
||
% - use \indexSection $sortstring $markup to divide the index into several sections
|
||
% - display the alphabetical index with \markuplines \index
|
||
|
||
% code ist mostly taken from ./ly/toc-init.ly and just renamed and slightly modfied
|
||
|
||
%% defined later, in a closure
|
||
#(define*-public (add-index-item! markup-symbol text sorttext #:optional label) #f)
|
||
#(define-public (index-items) #f)
|
||
|
||
#(let ((index-item-list (list)))
|
||
(set! add-index-item!
|
||
(lambda* (markup-symbol textoptions sorttext #:optional (label (gensym "index")))
|
||
(set! index-item-list
|
||
;; We insert index items sorted from the beginning on and do
|
||
;; not sort them later - this saves pretty much computing time
|
||
(insert-alphabetical-sorted! (list label markup-symbol textoptions
|
||
;; this crazy hack is necessary because lilypond depends on guile 1.8 atm
|
||
;; and so the cool unicode conversion functions cannot be used
|
||
(ly:string-substitute " " ""
|
||
(ly:string-substitute "…" ""
|
||
(ly:string-substitute "Č" "C"
|
||
(ly:string-substitute "Đ" "D"
|
||
(ly:string-substitute "Š" "S"
|
||
(ly:string-substitute "Т" "T"
|
||
(ly:string-substitute "Ä" "Ae"
|
||
(ly:string-substitute "ä" "ae"
|
||
(ly:string-substitute "Ö" "O"
|
||
(ly:string-substitute "ö" "oe"
|
||
(ly:string-substitute "Ü" "U"
|
||
(ly:string-substitute "ü" "ue" sorttext)))))))))))))
|
||
index-item-list))
|
||
(make-music 'EventChord
|
||
'page-marker #t
|
||
'page-label label
|
||
'elements (list (make-music 'LabelEvent
|
||
'page-label label)))))
|
||
(set! index-items (lambda ()
|
||
index-item-list)))
|
||
|
||
#(define (insert-alphabetical-sorted! iitem ilist)
|
||
(if (null? ilist)
|
||
(list iitem)
|
||
(if (string-ci<? (cadddr iitem) (cadddr (car ilist)))
|
||
(cons iitem ilist)
|
||
(cons (car ilist) (insert-alphabetical-sorted! iitem (cdr ilist))))))
|
||
|
||
% code for category index
|
||
#(define*-public (add-category-index-item! categories markup-symbol textoptions #:optional label) #f)
|
||
#(define-public (category-index-items) #f)
|
||
|
||
#(let ((category-index-hash (make-hash-table)))
|
||
(set! add-category-index-item!
|
||
(lambda* (categories markup-symbol textoptions #:optional (label (gensym "index")))
|
||
(for-each (lambda (category)
|
||
(let* ((catsym (string->symbol category))
|
||
(catlist (hashq-ref category-index-hash catsym
|
||
(list (list label 'indexCategoryMarkup `(((rawtext . ,category))))))))
|
||
(if (assq catsym category-names)
|
||
(hashq-set! category-index-hash catsym
|
||
(cons (list label markup-symbol textoptions) catlist))
|
||
(ly:error "song: <~a> category ~a is not defined!" (markup->string (chain-assoc-get 'rawtext textoptions)) category))))
|
||
categories)
|
||
(make-music 'EventChord
|
||
'page-marker #t
|
||
'page-label label
|
||
'elements (list (make-music 'LabelEvent
|
||
'page-label label)))))
|
||
(set! category-index-items (lambda ()
|
||
(append-map (lambda (kv) (reverse (hashq-ref category-index-hash (car kv) (list)))) category-names))))
|
||
|
||
% code for author index
|
||
#(define*-public (add-author-index-item! authorIDs markup-symbol text #:optional label) #f)
|
||
#(define-public (author-index-items) #f)
|
||
|
||
#(let ((author-index-hash (make-hash-table)))
|
||
(set! add-author-index-item!
|
||
(lambda* (authorIDs markup-symbol textoptions #:optional (label (gensym "index")))
|
||
(for-each (lambda (authorID)
|
||
(let* ((authorsym (string->symbol authorID))
|
||
(authorlist (hashq-ref author-index-hash authorsym
|
||
(list (list label 'indexAuthorMarkup `(((rawtext . ,authorID))))))))
|
||
(hashq-set! author-index-hash authorsym
|
||
(cons (list label markup-symbol textoptions) authorlist))
|
||
))
|
||
authorIDs)
|
||
(make-music 'EventChord
|
||
'page-marker #t
|
||
'page-label label
|
||
'elements (list (make-music 'LabelEvent
|
||
'page-label label)))))
|
||
(set! author-index-items (lambda ()
|
||
(append-map cdr
|
||
(sort-list
|
||
(hash-map->list
|
||
(lambda (authorsym authorlist) (cons (string-downcase (symbol->string authorsym)) (reverse authorlist)))
|
||
author-index-hash)
|
||
(lambda (a b) (string-ci<? (car a) (car b))))))))
|
||
|
||
|
||
#(define-markup-command (with-link-symbol-ref layout props symbol arg)
|
||
(symbol? markup?)
|
||
"call with-link with the label referenced by symbol"
|
||
(let ((label (chain-assoc-get symbol props)))
|
||
(interpret-markup layout props
|
||
(markup #:with-link label arg))))
|
||
|
||
#(define-markup-command (category-image-symbol-ref layout props size symbol)
|
||
(number? symbol?)
|
||
"call category-image with the category referenced by symbol"
|
||
(let ((category (chain-assoc-get symbol props)))
|
||
(interpret-markup layout props
|
||
(markup #:category-image size category))))
|
||
|
||
#(define-markup-command (category-name-symbol-ref layout props symbol)
|
||
(symbol?)
|
||
"get the name of a category referenced by symbol"
|
||
(let* ((category (chain-assoc-get symbol props))
|
||
(catname (assq (string->symbol category) category-names)))
|
||
(interpret-markup layout props
|
||
(markup #:override (cons 'baseline-skip 3.5) (if catname (make-left-column-markup (string-split (cadr catname) #\newline)) category)))))
|
||
|
||
#(define-markup-command (index-item-with-pattern layout props)()
|
||
#:properties ((index:text "")
|
||
(index:alternative #f)
|
||
(index:page #f)
|
||
(line-width))
|
||
(let* (
|
||
(width (-
|
||
line-width
|
||
(interval-length (ly:stencil-extent (interpret-markup layout props "XXXX") X))))
|
||
(lines-reversed
|
||
(reverse (map (lambda (stil) (markup #:stencil stil))
|
||
(wordwrap-string-internal-markup-list layout
|
||
(prepend-alist-chain 'line-width width
|
||
(if index:alternative
|
||
(prepend-alist-chain 'font-shape 'italic props)
|
||
props))
|
||
#f
|
||
index:text))))
|
||
(last-line-with-dots (make-fill-with-pattern-markup 1 RIGHT "." (car lines-reversed) index:page))
|
||
(lines-without-dots (cdr lines-reversed))
|
||
(target-line-size-markup
|
||
(make-column-markup
|
||
(list
|
||
(make-simple-markup "Agj")
|
||
(make-vspace-markup 0.2))))
|
||
)
|
||
(interpret-markup layout props
|
||
(make-size-box-to-box-markup #f #t
|
||
(make-with-link-symbol-ref-markup 'index:label
|
||
(make-column-markup
|
||
(reverse (cons
|
||
last-line-with-dots
|
||
(map (lambda (m) (make-size-box-to-box-markup #f #t m target-line-size-markup)) lines-without-dots)))))
|
||
; this column is just to have a reference height for resizing
|
||
(make-column-markup
|
||
(reverse (map (lambda (m) (make-size-box-to-box-markup #f #t m target-line-size-markup)) (cons last-line-with-dots lines-without-dots))))
|
||
))))
|
||
|
||
\paper {
|
||
indexItemMarkup = \markup {
|
||
\sans \index-item-with-pattern
|
||
}
|
||
indexSectionMarkup = \markup \override #'(baseline-skip . 1.5) \left-column {
|
||
\sans \bold \fontsize #3 \fromproperty #'index:text
|
||
\null
|
||
}
|
||
indexCategoryMarkup = \markup \override #'(baseline-skip . 1.5) \column {
|
||
\fill-line { \line { \vcenter \category-image-symbol-ref #7 #'index:text \hspace #3 \vcenter \sans \bold \fontsize #3 \category-name-symbol-ref #'index:text } \null }
|
||
\vspace #.4
|
||
}
|
||
indexAuthorMarkup = \markup \override #'(baseline-skip . 1.5) \left-column {
|
||
\vspace #1
|
||
\sans \bold \fontsize #3
|
||
#(make-on-the-fly-markup
|
||
(lambda (layout props m)
|
||
(interpret-markup layout props
|
||
(make-justify-string-markup (format-author (ly:output-def-lookup layout 'authorFormat) (chain-assoc-get 'index:text props #f) #t))))
|
||
(make-null-markup))
|
||
\vspace #.4
|
||
}
|
||
}
|
||
|
||
#(define (prepare-item-markup items layout)
|
||
(map (lambda (index-item)
|
||
(let* ((label (car index-item))
|
||
(index-markup (cadr index-item))
|
||
(textoptions (caddr index-item))
|
||
(text (chain-assoc-get 'rawtext textoptions))
|
||
(alternative (chain-assoc-get 'alternative textoptions))
|
||
(songnumber (chain-assoc-get 'songnumber textoptions)))
|
||
(markup #:override (cons 'index:label label)
|
||
#:override (cons 'index:page (markup #:custom-page-number label -1))
|
||
#:override (cons 'index:text text)
|
||
#:override (cons 'index:alternative alternative)
|
||
#:override (cons 'index:songnumber songnumber)
|
||
(ly:output-def-lookup layout index-markup))))
|
||
(items)))
|
||
|
||
#(define-markup-list-command (index-in-columns-with-title layout props index-type title-markup) (symbol? markup?)
|
||
( _i "Outputs index alphabetical sorted or in categories" )
|
||
(let ((items (case index-type
|
||
((alphabetical) index-items)
|
||
((categories) category-index-items)
|
||
((authors) author-index-items)))
|
||
(title (interpret-markup layout props title-markup)))
|
||
(cons title
|
||
(interpret-markup-list layout props
|
||
(make-columnlayout-markup-list songTocColumns 2
|
||
(let ((h (- (ly:output-def-lookup layout 'paper-height) 12)))
|
||
(cons (- h (interval-length (ly:stencil-extent title Y))) h))
|
||
(prepare-item-markup items layout))))))
|
||
|
||
indexItem =
|
||
#(define-music-function (parser location sorttext text) (string? markup?)
|
||
"Add a line to the alphabetical index, using the @code{indexItemMarkup} paper variable markup."
|
||
(add-index-item! 'indexItemMarkup (prepend-alist-chain 'rawtext text '()) sorttext))
|
||
|
||
indexSection =
|
||
#(define-music-function (parser location sorttext text) (string? markup?)
|
||
"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 (prepend-alist-chain 'rawtext text '()) sorttext))
|
||
|
||
#(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?)
|
||
(define (all-author-ids authors)
|
||
(let ((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))
|
||
(adaptionIds (find-author-ids-by 'adaption authors))
|
||
(bridgeIds (find-author-ids-by 'bridge authors))
|
||
(interludeIds (find-author-ids-by 'interlude authors)))
|
||
(delete-duplicates
|
||
(append poetIds translatorIds (map car versePoetData) composerIds (map car verseComposerData) (map car voiceComposerData) compositionIds adaptionIds bridgeIds interludeIds))
|
||
))
|
||
(let*
|
||
(
|
||
(extractedheadervars (extract-and-check-vars-from-header header '(title starttext alttitle categorytitle categories authors songnumber)))
|
||
(title (assq-ref extractedheadervars 'title))
|
||
(starttext (assq-ref extractedheadervars 'starttext))
|
||
(alttitle (assq-ref extractedheadervars 'alttitle))
|
||
(categorytitle (assq-ref extractedheadervars 'categorytitle))
|
||
(categories (assq-ref extractedheadervars 'categories))
|
||
(authors (assq-ref extractedheadervars 'authors))
|
||
(songnumber (assq-ref extractedheadervars 'songnumber))
|
||
(textoptions (lambda (text alternative) `(((rawtext . ,text) (alternative . ,alternative) (songnumber . ,songnumber)))))
|
||
(add-to-toc! (lambda (toctitle alternative)
|
||
(add-index-item! 'indexItemMarkup (textoptions toctitle alternative) toctitle label)))
|
||
)
|
||
(if categories (add-category-index-item! (string-tokenize categories) 'indexItemMarkup (textoptions (if categorytitle categorytitle title) #f) label))
|
||
(if authors (add-author-index-item! (all-author-ids authors) 'indexItemMarkup (textoptions (if categorytitle categorytitle title) #f) label))
|
||
(if starttext (add-to-toc! starttext #t))
|
||
(if alttitle
|
||
(if (list? alttitle)
|
||
(for-each (lambda (alt)
|
||
(add-to-toc! alt #t))
|
||
alttitle)
|
||
(add-to-toc! alttitle #t)))
|
||
(if title (add-to-toc! title #f) #{ #})
|
||
))
|
||
|
||
|
||
%% 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 (ly:output-def-lookup layout 'authorFormat) 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 categorytitle categories authors year_text year_melody year_translation year_composition year_adaption 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))
|
||
(adaptionTextIds (find-author-ids-by 'adaption_text authors))
|
||
(adaptionMusicIds (find-author-ids-by 'adaption_music 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)
|
||
(let ((alttitle-value (headervar-or-empty 'alttitle)))
|
||
(if (list? alttitle-value)
|
||
(string-join alttitle-value ", ") ; Wenn eine Liste, dann zusammenfügen
|
||
alttitle-value)) ; Wenn kein Liste, den originalen Wert verwenden
|
||
|
||
(headervar-or-empty 'categorytitle)
|
||
(headervar-or-empty 'categories)
|
||
(format-authors (append poetIds adaptionTextIds (map car versePoetData)))
|
||
(format-authors translatorIds)
|
||
(format-authors (append composerIds compositionIds adaptionMusicIds 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 'year_adaption_text)
|
||
(headervar-or-empty 'year_adaption_music)
|
||
(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"
|
||
"categorytitle"
|
||
"categories"
|
||
"poets"
|
||
"translators"
|
||
"composers"
|
||
"year_text"
|
||
"year_melody"
|
||
"year_translation"
|
||
"year_composition"
|
||
"year_adaption_text"
|
||
"year_adaption_music"
|
||
"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)))))
|