Compare commits
29 Commits
4b7d1a46eb
...
chordpro
| Author | SHA1 | Date | |
|---|---|---|---|
| 85c05cec5d | |||
| 6e528a5328 | |||
| 71c8c0385c | |||
| f075946777 | |||
| a0de02126c | |||
| 7ece3b9c10 | |||
| 7fc99e8883 | |||
| b3feb3aa6d | |||
| 7b166f6fc3 | |||
| 9c437d0f06 | |||
| a52f993678 | |||
| bbd6d44455 | |||
| f68e2f10ae | |||
| 463d61fbd9 | |||
| 2d14a5b632 | |||
| 368a1b96aa | |||
| f57b1c4ec3 | |||
| e530bdf090 | |||
| c97c856b05 | |||
| 76b81a9968 | |||
| 3ff5a36106 | |||
| 7c92c65c82 | |||
| b2f1a7dc86 | |||
| 893010c4a9 | |||
| 8aa0e3fdc3 | |||
| 5364f93db4 | |||
| aa0e3816d0 | |||
| 3b0c320839 | |||
| 12abf0a5f7 |
2
.gitignore
vendored
2
.gitignore
vendored
@@ -1,8 +1,8 @@
|
||||
# ---> Lilypond
|
||||
*.pdf
|
||||
*.cho
|
||||
*.ps
|
||||
*.midi
|
||||
*.mid
|
||||
*.log
|
||||
*~
|
||||
|
||||
|
||||
@@ -19,17 +19,28 @@
|
||||
(string-append (dirname (current-filename)) file-name-separator-string))
|
||||
"scm" file-name-separator-string filename
|
||||
)))))
|
||||
(scm-load "json_parser.scm")
|
||||
(scm-load "resolve_inherits.scm")
|
||||
(scm-load "yaml_parser.scm")))
|
||||
#(define AUTHOR_DATA (if (defined? 'AUTHOR_DATA) AUTHOR_DATA (parse-yml-file "../../lilypond-song-includes/data/authors.yml")))
|
||||
#(define SONG_DATA (if (defined? 'SONG_DATA) SONG_DATA (parse-yml-file "../../lilypond-song-includes/data/songs.yml")))
|
||||
|
||||
#(define (song-includes-data-path filename)
|
||||
(string-join
|
||||
(list
|
||||
(dirname (dirname (dirname (dirname (current-filename)))))
|
||||
"lilypond-song-includes"
|
||||
"data"
|
||||
filename)
|
||||
file-name-separator-string))
|
||||
#(define AUTHOR_DATA (if (defined? 'AUTHOR_DATA) AUTHOR_DATA (parse-yml-file (song-includes-data-path "authors.yml"))))
|
||||
#(define SONG_DATA (if (defined? 'SONG_DATA) SONG_DATA (parse-yml-file (song-includes-data-path "songs.yml"))))
|
||||
|
||||
\include "merge_rests_engraver_override.ily"
|
||||
\include "basic_format_and_style_settings.ily"
|
||||
\include "eps_file_from_song_dir.ily"
|
||||
\include "title_with_category_images.ily"
|
||||
\include "chord_settings.ily"
|
||||
\include "chordpro.ily"
|
||||
\include "transposition.ily"
|
||||
\include "markup_tag_groups_hack.ily"
|
||||
\include "verses_with_chords.ily"
|
||||
\include "arrows_in_scores.ily"
|
||||
\include "swing_style.ily"
|
||||
@@ -47,3 +58,5 @@ TEXT_PAGES = #f
|
||||
verseChords = {}
|
||||
firstVoice = {}
|
||||
global = {}
|
||||
|
||||
\resetTagGroups
|
||||
|
||||
@@ -29,6 +29,11 @@
|
||||
(if (null? stanzanumbers)
|
||||
refString
|
||||
(ly:format refStringWithNumbers (string-join (map (lambda (stanzanumber) (ly:format "~a" stanzanumber)) stanzanumbers) ", ")))))
|
||||
bridgeMarkupFormatter = #(lambda (layout props stanzanumbers)
|
||||
(interpret-markup layout props
|
||||
(if (null? stanzanumbers)
|
||||
bridgeString
|
||||
(ly:format bridgeStringWithNumbers (string-join (map (lambda (stanzanumber) (ly:format "~a" stanzanumber)) stanzanumbers) ", ")))))
|
||||
}
|
||||
|
||||
generalLayout = \layout {
|
||||
@@ -44,11 +49,12 @@ generalLayout = \layout {
|
||||
\context {
|
||||
\Staff
|
||||
\accidentalStyle modern-voice-cautionary
|
||||
\consists Merge_rests_engraver
|
||||
\consists \Better_Merge_rests_engraver
|
||||
}
|
||||
\context {
|
||||
\Score
|
||||
\remove "Bar_number_engraver"
|
||||
\remove "Metronome_mark_engraver"
|
||||
\RemoveEmptyStaves
|
||||
\override VerticalAxisGroup.remove-first = ##t
|
||||
\overrideTimeSignatureSettings
|
||||
@@ -67,14 +73,22 @@ generalLayout = \layout {
|
||||
% ich will lines breaken wie ich will!
|
||||
\remove "Forbid_line_break_engraver"
|
||||
\override NoteHead.layer = 2
|
||||
\override Rest.layer = 2
|
||||
\override Dots.layer = 2
|
||||
\override Stem.layer = 2
|
||||
\override Flag.layer = 2
|
||||
\override Beam.layer = 2
|
||||
\override Slur.layer = 2
|
||||
\override Tie.layer = 2
|
||||
\override Accidental.layer = 2
|
||||
}
|
||||
}
|
||||
|
||||
#(define (customized-layout base-layout)
|
||||
(let
|
||||
((custom-size (ly:output-def-lookup base-layout 'size #f)))
|
||||
(if custom-size (layout-set-staff-size custom-size))))
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%%% kleine Helferlein:
|
||||
|
||||
@@ -83,25 +97,34 @@ textp = \lyricmode { \markup { \raise #1 \musicglyph #"rests.3" } }
|
||||
% zweite Stimme alles grau
|
||||
secondVoiceStyle = {
|
||||
\override NoteHead.color = #grey
|
||||
\override Rest.color = #grey
|
||||
\override Dots.color = #grey
|
||||
\override Stem.color = #grey
|
||||
\override Flag.color = #grey
|
||||
\override Beam.color = #grey
|
||||
\override Slur.color = #grey
|
||||
\override Tie.color = #grey
|
||||
\override Accidental.color = #grey
|
||||
\override NoteHead.layer = 1
|
||||
\override Rest.layer = 1
|
||||
\override Dots.layer = 1
|
||||
\override Stem.layer = 1
|
||||
\override Flag.layer = 1
|
||||
\override Beam.layer = 1
|
||||
\override Slur.layer = 1
|
||||
\override Tie.layer = 1
|
||||
\override Accidental.layer = 1
|
||||
}
|
||||
|
||||
firstVoiceStyle = {
|
||||
\override NoteHead.color = #black
|
||||
\override Rest.color = #black
|
||||
\override Dots.color = #black
|
||||
\override Stem.color = #black
|
||||
\override Flag.color = #black
|
||||
\override Beam.color = #black
|
||||
\override Slur.color = #black
|
||||
\override Tie.color = #black
|
||||
\override Accidental.color = #black
|
||||
}
|
||||
|
||||
@@ -115,45 +138,84 @@ romanStanza =
|
||||
#{ \override StanzaNumber.style = #'roman #})
|
||||
|
||||
override-stanza =
|
||||
#(define-music-function (parser location stanzanumber) (number?)
|
||||
#(define-music-function (parser location stanzanumbers) (number-list?)
|
||||
#{
|
||||
\once \override StanzaNumber.forced-spacing = #stanzanumber % misuse property "forced-spacing" to override the stanzanumber
|
||||
\once \override StanzaNumber.details.custom-stanzanumber-override = #stanzanumbers
|
||||
#}
|
||||
)
|
||||
|
||||
#(define (handle-stanza-numbers context numbers number-formater)
|
||||
(let* ((stanzanumbers (ly:assoc-get 'custom-stanzanumber-override (ly:assoc-get 'details (ly:context-grob-definition context 'StanzaNumber) '()) numbers))
|
||||
(stanza-style (ly:assoc-get 'style (ly:context-grob-definition context 'StanzaNumber)))
|
||||
(roman-format (lambda (stanzanumber) (format #f "~@r" stanzanumber))))
|
||||
(ly:context-set-property! context 'stanza
|
||||
(make-pad-left-markup 1
|
||||
(number-formater
|
||||
(if (eq? stanza-style 'roman)
|
||||
(map roman-format stanzanumbers)
|
||||
stanzanumbers))))))
|
||||
|
||||
#(define (stanza . stanzanumbers)
|
||||
#{
|
||||
\once \override StanzaNumber.layer = 23 % set this to signal that there is a real stanza and no repeat signs
|
||||
\once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs
|
||||
\once \override StanzaNumber.details.custom-stanza-type = #'verse
|
||||
\once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers
|
||||
\applyContext
|
||||
#(lambda (context)
|
||||
(let* ((stanzanumber-override (ly:assoc-get 'forced-spacing (ly:context-grob-definition context 'StanzaNumber) #f))
|
||||
(stanza-style (ly:assoc-get 'style (ly:context-grob-definition context 'StanzaNumber)))
|
||||
(stanza-format (lambda (stanzanumber) (format #f (if (eq? stanza-style 'roman) romanStanzaFormat stanzaFormat) stanzanumber))))
|
||||
(ly:context-set-property! context 'stanza
|
||||
(string-join (map stanza-format
|
||||
(if stanzanumber-override (list stanzanumber-override) stanzanumbers))
|
||||
", "))))
|
||||
(handle-stanza-numbers context stanzanumbers
|
||||
(lambda (numbers) (string-join (map (lambda (n) (format #f stanzaFormat n)) numbers) ", "))))
|
||||
#}
|
||||
)
|
||||
|
||||
ref =
|
||||
#(define-music-function (stanzanumbers lyrics) ((number-list? (list)) ly:music?)
|
||||
#{ \lyricmode {
|
||||
\once \override StanzaNumber.layer = 23 % set this to signal that there is a real stanza and no repeat signs
|
||||
\set stanza = #(make-on-the-fly-markup (lambda (layout props m) ((ly:output-def-lookup layout 'refMarkupFormatter) layout props stanzanumbers)) (make-null-markup))
|
||||
\once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs
|
||||
\once \override StanzaNumber.details.custom-stanza-type = #'ref
|
||||
\once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers
|
||||
\applyContext
|
||||
#(lambda (context)
|
||||
(handle-stanza-numbers context stanzanumbers
|
||||
(lambda (numbers)
|
||||
(make-on-the-fly-markup
|
||||
(lambda (layout props m)
|
||||
((ly:output-def-lookup layout 'refMarkupFormatter) layout props numbers))
|
||||
(make-null-markup)))))
|
||||
#lyrics
|
||||
}
|
||||
#}
|
||||
)
|
||||
|
||||
bridge =
|
||||
#(define-music-function (stanzanumbers lyrics) ((number-list? (list)) ly:music?)
|
||||
#{ \lyricmode {
|
||||
\once \override StanzaNumber.details.custom-realstanza = ##t % set this to signal that there is a real stanza and no repeat signs
|
||||
\once \override StanzaNumber.details.custom-stanza-type = #'bridge
|
||||
\once \override StanzaNumber.details.custom-stanza-numbers = #stanzanumbers
|
||||
\applyContext
|
||||
#(lambda (context)
|
||||
(handle-stanza-numbers context stanzanumbers
|
||||
(lambda (numbers)
|
||||
(make-on-the-fly-markup
|
||||
(lambda (layout props m)
|
||||
((ly:output-def-lookup layout 'bridgeMarkupFormatter) layout props numbers))
|
||||
(make-null-markup)))))
|
||||
#lyrics
|
||||
}
|
||||
#}
|
||||
)
|
||||
|
||||
% prints a repStart Sign as stanza if the tag 'repeats is kept.
|
||||
% if there was a stanza already set by the stanza function with StanzaNumber.layer = 23 we set that also as stanza.
|
||||
% if there was a stanza already set by the stanza function with StanzaNumber.details.custom-realstanza = ##t we set that also as stanza.
|
||||
% Sets custom-inline-text for ChordPro export so it can collect the repeat sign separately
|
||||
repStartWithTag = \lyricmode {
|
||||
\tag #'repeats {
|
||||
\once \override StanzaNumber.details.custom-inline-text = \repStart
|
||||
\once \override StanzaNumber.details.custom-inline-direction = #LEFT
|
||||
\applyContext
|
||||
#(lambda (context)
|
||||
(let ((lastStanza (ly:context-property context 'stanza))
|
||||
(printLastStanza (= (ly:assoc-get 'layer (ly:context-grob-definition context 'StanzaNumber) 0) 23))
|
||||
(printLastStanza (ly:assoc-get 'custom-realstanza (ly:assoc-get 'details (ly:context-grob-definition context 'StanzaNumber) '()) #f))
|
||||
(stanzaFontSeries (ly:assoc-get 'font-series (ly:context-grob-definition context 'StanzaNumber) 'normal)))
|
||||
(ly:context-set-property! context 'stanza
|
||||
(make-concat-markup
|
||||
@@ -167,9 +229,11 @@ repStartWithTag = \lyricmode {
|
||||
|
||||
repStopWithTag = \lyricmode {
|
||||
\tag #'repeats {
|
||||
\once \override StanzaNumber.details.custom-inline-text = \repStop
|
||||
\once \override StanzaNumber.details.custom-inline-direction = #RIGHT
|
||||
\once \override StanzaNumber.font-series = #'normal
|
||||
\once \override StanzaNumber.direction = 1
|
||||
\set stanza = \markup { \repStop }
|
||||
\set stanza = \markup { \pad-x-right #1 \repStop }
|
||||
}
|
||||
}
|
||||
|
||||
@@ -253,3 +317,17 @@ rufWithMarkup =
|
||||
ruf =
|
||||
#(define-music-function (text) (string?)
|
||||
(rufWithMarkup (make-ruf-style-markup text)))
|
||||
|
||||
underlineOn =
|
||||
#(define-music-function () ()
|
||||
#{
|
||||
\override LyricText.stencil =
|
||||
#(lambda (grob)
|
||||
(grob-interpret-markup grob (make-underline-markup (ly:grob-property grob 'text))))
|
||||
#})
|
||||
|
||||
underlineOff =
|
||||
#(define-music-function () ()
|
||||
#{
|
||||
\revert LyricText.stencil
|
||||
#})
|
||||
|
||||
@@ -40,34 +40,19 @@ shiftChords = #(define-music-function (parser location xshift chords) (number? l
|
||||
|
||||
altChord =
|
||||
#(define-music-function (parser location mainchord altchord) (ly:music? ly:music?)
|
||||
(let* ((remove-point-and-click
|
||||
(lambda (grob)
|
||||
(ly:grob-set-property! grob 'cause #f)
|
||||
(ly:text-interface::print grob)))
|
||||
(chord-name (lambda (in-pitches bass inversion context) #{
|
||||
\markup {
|
||||
\translate #'(-0.5 . 0)
|
||||
\score {
|
||||
\chords { \transposable #(cons (car (music-pitches mainchord)) (car in-pitches)) { #(music-clone mainchord) \klamm #(music-clone altchord) } }
|
||||
\layout {
|
||||
\LAYOUT
|
||||
\context {
|
||||
\ChordNames
|
||||
\override ChordName.extra-spacing-width = #'(0 . 0.3)
|
||||
\override ChordName.stencil = #remove-point-and-click
|
||||
}
|
||||
\context {
|
||||
\Score
|
||||
\override SpacingSpanner.spacing-increment = 0
|
||||
}
|
||||
}
|
||||
}
|
||||
}#})))
|
||||
(let* ((chord-name (lambda (in-pitches bass inversion context)
|
||||
(make-line-markup (list
|
||||
(ignatzek-chord-names in-pitches bass inversion context)
|
||||
(make-hspace-markup 0.3)
|
||||
(parenthesis-ignatzek-chord-names (music-pitches (transposable (cons (car (music-pitches mainchord)) (car in-pitches)) (music-clone altchord))) '() '() context)
|
||||
))
|
||||
)))
|
||||
#{
|
||||
\once \set chordNameFunction = #chord-name
|
||||
#mainchord
|
||||
#}))
|
||||
|
||||
|
||||
% Akkorde werden so transponiert, dass sie passen, wenn man mit Kapo im angegebenen Bund spielt
|
||||
capoTranspose =
|
||||
#(define-music-function (fret chords) (number? ly:music?)
|
||||
@@ -80,41 +65,8 @@ capoTranspose =
|
||||
(ly:make-pitch 0 0)
|
||||
chords))
|
||||
|
||||
% kleine Mollakkorde und Alteration ausgeschrieben
|
||||
#(define (note-name->german-markup-nosym pitch lowercase?)
|
||||
(define (pitch-alteration-semitones pitch) (inexact->exact (round (* (ly:pitch-alteration pitch) 2))))
|
||||
(define (accidental->markup alteration name)
|
||||
(if (= alteration 0)
|
||||
(make-line-markup (list empty-markup))
|
||||
(if (= alteration FLAT)
|
||||
(if (equal? name "B")
|
||||
""
|
||||
; (make-line-markup (list (make-hspace-markup 0.2)
|
||||
; (make-tiny-markup (make-raise-markup 1.2
|
||||
; (make-musicglyph-markup (assoc-get alteration standard-alteration-glyph-name-alist ""))))
|
||||
; ))
|
||||
(if (or (equal? name "E") (equal? name "A")) "s" "es"))
|
||||
"is")
|
||||
))
|
||||
(define (conditional-string-downcase str condition)
|
||||
(if condition (string-downcase str) str))
|
||||
|
||||
(let* ((name (ly:pitch-notename pitch))
|
||||
(alt-semitones (pitch-alteration-semitones pitch))
|
||||
(n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2)))
|
||||
(cons 7 (+ 0 alt-semitones))
|
||||
(cons name alt-semitones))))
|
||||
(make-line-markup
|
||||
(list
|
||||
(make-simple-markup
|
||||
(conditional-string-downcase
|
||||
(vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a))
|
||||
lowercase?))
|
||||
(accidental->markup (/ (cdr n-a) 2) (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a)) ))))
|
||||
)
|
||||
|
||||
% additional bass notes should get uppercased
|
||||
#(define (bassnote-name->german-markup-nosym pitch lowercase?)(note-name->german-markup-nosym pitch #f))
|
||||
#(define (bassnote-name->german-markup-nosym pitch lowercase?)((chord-name:name-markup 'deutsch) pitch #f))
|
||||
|
||||
defaultChordPrintings = {
|
||||
<c g>-\markup { \super "5" }
|
||||
@@ -157,15 +109,15 @@ generalLayout = \layout {
|
||||
\generalLayout
|
||||
\context {
|
||||
\ChordNames
|
||||
\semiGermanChords
|
||||
\override ChordName.font-size = \songScoreChordFontSize
|
||||
\override ChordName.font-series = \songChordFontSeries
|
||||
\override ChordName.font-family = #'serif
|
||||
chordNameLowercaseMinor = ##t
|
||||
chordChanges = ##t
|
||||
% eigenen chordRootNamer damit F# = Fis und Gb = Ges (also alteration ausgeschrieben)
|
||||
chordRootNamer = #note-name->german-markup-nosym
|
||||
chordRootNamer = #(chord-name:name-markup 'deutsch)
|
||||
chordNoteNamer = #bassnote-name->german-markup-nosym
|
||||
additionalPitchPrefix = ""
|
||||
|
||||
majorSevenSymbol = "maj7"
|
||||
chordNameExceptions = \chordNameExceptions
|
||||
}
|
||||
|
||||
997
private_includes/base/chordpro.ily
Normal file
997
private_includes/base/chordpro.ily
Normal file
@@ -0,0 +1,997 @@
|
||||
%% ChordPro Export Engraver
|
||||
%% =========================
|
||||
%% Single engraver in Score context that collects all data
|
||||
|
||||
#(use-modules (ice-9 format))
|
||||
#(use-modules (srfi srfi-1))
|
||||
|
||||
%% Helper function to convert German minor chord notation to standard major form
|
||||
%% Used for generating {define:} directives
|
||||
#(define (german-minor-to-major-form chord-str)
|
||||
"Convert lowercase German minor chords (e.g., 'a7', 'fis') to standard form (e.g., 'Am7', 'Fism')"
|
||||
(if (or (not (string? chord-str)) (string-null? chord-str))
|
||||
chord-str
|
||||
(let* ((first-char (string-ref chord-str 0)))
|
||||
(if (char-lower-case? first-char)
|
||||
;; It's a minor chord - capitalize first letter and add 'm' after accidentals
|
||||
(let* ((rest-str (if (> (string-length chord-str) 1)
|
||||
(substring chord-str 1)
|
||||
""))
|
||||
;; Find where to insert 'm': after 'is' or 'es' if present, otherwise right after root
|
||||
(insert-pos (cond
|
||||
((string-prefix? "is" rest-str) 2)
|
||||
((string-prefix? "es" rest-str) 2)
|
||||
(else 0)))
|
||||
(before-m (substring rest-str 0 insert-pos))
|
||||
(after-m (substring rest-str insert-pos)))
|
||||
(string-append (string (char-upcase first-char)) before-m "m" after-m))
|
||||
;; Already uppercase - return as is
|
||||
chord-str))))
|
||||
|
||||
%% Helper function to convert German accidentals to international format
|
||||
#(define (german-accidentals-to-international chord-str)
|
||||
"Convert German 'is' to '#' and 'es' to 'b' (e.g., 'fis' -> 'F#', 'as' -> 'Ab')"
|
||||
(if (or (not (string? chord-str)) (string-null? chord-str))
|
||||
chord-str
|
||||
(let* ((first-char (string-ref chord-str 0))
|
||||
(rest-str (if (> (string-length chord-str) 1)
|
||||
(substring chord-str 1)
|
||||
""))
|
||||
;; Check for 'is' (sharp) or 'es' (flat)
|
||||
(has-is (string-prefix? "is" rest-str))
|
||||
(has-es (string-prefix? "es" rest-str))
|
||||
;; Convert root note
|
||||
(root-upper (string (char-upcase first-char)))
|
||||
;; Process accidentals and rest
|
||||
(processed-rest
|
||||
(cond
|
||||
(has-is ; fis -> F#, cis -> C#
|
||||
(string-append "#" (substring rest-str 2)))
|
||||
(has-es ; as -> Ab, es -> Eb
|
||||
(string-append "b" (substring rest-str 2)))
|
||||
(else rest-str))))
|
||||
;; Special case: if it's a minor chord (lowercase), add 'm' after accidental
|
||||
(if (char-lower-case? first-char)
|
||||
;; Minor: add 'm' after accidental
|
||||
(if (or has-is has-es)
|
||||
(string-append root-upper (substring processed-rest 0 1) "m" (substring processed-rest 1))
|
||||
(string-append root-upper "m" processed-rest))
|
||||
;; Major: just return converted
|
||||
(string-append root-upper processed-rest)))))
|
||||
|
||||
%% Helper function to convert B/b chords to Bb/Bbm form for {define:} directives
|
||||
#(define (german-b-to-bb-form chord-str)
|
||||
"Convert B/b chords to Bb/Bbm format (e.g., 'B7' -> 'Bb7', 'b' -> 'Bbm', 'b7' -> 'Bbm7')"
|
||||
(if (or (not (string? chord-str)) (string-null? chord-str))
|
||||
chord-str
|
||||
(let ((first-char (string-ref chord-str 0)))
|
||||
(cond
|
||||
;; Uppercase B -> Bb + rest
|
||||
((char=? first-char #\B)
|
||||
(string-append "Bb" (substring chord-str 1)))
|
||||
;; Lowercase b -> Bbm + rest (it's b-minor)
|
||||
((char=? first-char #\b)
|
||||
(let ((rest-str (if (> (string-length chord-str) 1)
|
||||
(substring chord-str 1)
|
||||
"")))
|
||||
(string-append "Bbm" rest-str)))
|
||||
(else chord-str)))))
|
||||
|
||||
%% Helper function to convert H/h chords to B/Bm form for {define:} directives
|
||||
#(define (german-h-to-b-form chord-str)
|
||||
"Convert H/h chords to B/Bm format (e.g., 'H7' -> 'B7', 'h' -> 'Bm', 'h7' -> 'Bm7')"
|
||||
(if (or (not (string? chord-str)) (string-null? chord-str))
|
||||
chord-str
|
||||
(let ((first-char (string-ref chord-str 0)))
|
||||
(cond
|
||||
;; Uppercase H -> B + rest
|
||||
((char=? first-char #\H)
|
||||
(string-append "B" (substring chord-str 1)))
|
||||
;; Lowercase h -> Bm + rest (it's h-minor)
|
||||
((char=? first-char #\h)
|
||||
(let ((rest-str (if (> (string-length chord-str) 1)
|
||||
(substring chord-str 1)
|
||||
"")))
|
||||
(string-append "Bm" rest-str)))
|
||||
(else chord-str)))))
|
||||
|
||||
%% Helper function to track minor/B/H/accidental chords and return original
|
||||
#(define (track-and-return-chord chord-str)
|
||||
"Track chords that need {define:} directives and return original."
|
||||
(if (or (not (string? chord-str)) (string-null? chord-str))
|
||||
chord-str
|
||||
(let* ((first-char (string-ref chord-str 0))
|
||||
(rest-str (if (> (string-length chord-str) 1)
|
||||
(substring chord-str 1)
|
||||
""))
|
||||
(has-is (string-prefix? "is" rest-str))
|
||||
(has-es (string-prefix? "es" rest-str))
|
||||
(has-accidental (or has-is has-es)))
|
||||
(cond
|
||||
;; H/h chords (German H = English B)
|
||||
((char=? first-char #\H)
|
||||
(unless (member chord-str chordpro-h-chords-used)
|
||||
(set! chordpro-h-chords-used (cons chord-str chordpro-h-chords-used))))
|
||||
((char=? first-char #\h)
|
||||
(unless (member chord-str chordpro-h-chords-used)
|
||||
(set! chordpro-h-chords-used (cons chord-str chordpro-h-chords-used))))
|
||||
|
||||
;; B/b chords (German B = English Bb)
|
||||
((char=? first-char #\B)
|
||||
(unless (member chord-str chordpro-b-chords-used)
|
||||
(set! chordpro-b-chords-used (cons chord-str chordpro-b-chords-used))))
|
||||
((char=? first-char #\b)
|
||||
(unless (member chord-str chordpro-b-chords-used)
|
||||
(set! chordpro-b-chords-used (cons chord-str chordpro-b-chords-used))))
|
||||
|
||||
;; Chords with accidentals (is/es)
|
||||
(has-accidental
|
||||
(unless (member chord-str chordpro-accidental-chords-used)
|
||||
(set! chordpro-accidental-chords-used (cons chord-str chordpro-accidental-chords-used))))
|
||||
|
||||
;; Other lowercase chords (minor without B/H/accidentals)
|
||||
((char-lower-case? first-char)
|
||||
(unless (member chord-str chordpro-minor-chords-used)
|
||||
(set! chordpro-minor-chords-used (cons chord-str chordpro-minor-chords-used)))))
|
||||
|
||||
;; Always return original
|
||||
chord-str)))
|
||||
|
||||
%% Helper function to convert chord music object to chord name string
|
||||
#(define (music-to-chord-name chord-music)
|
||||
"Extract pitches from a chord music object and convert to German chord name"
|
||||
(if (not chord-music)
|
||||
""
|
||||
(let* ((pitches (music-pitches chord-music)))
|
||||
(if (or (not pitches) (null? pitches))
|
||||
"" ; No pitches found
|
||||
(let* (;; Use ignatzek chord naming with German root names
|
||||
(chord-markup ((chord-name:name-markup 'deutsch) pitches #f #f #f))
|
||||
;; Convert markup to string
|
||||
(chord-str (if (markup? chord-markup)
|
||||
(markup->string chord-markup)
|
||||
""))
|
||||
;; Remove spaces
|
||||
(cleaned (string-delete #\space chord-str)))
|
||||
cleaned)))))
|
||||
|
||||
%% Helper function to normalize multiple spaces to single space
|
||||
#(define (normalize-spaces str)
|
||||
"Replace multiple consecutive spaces with a single space"
|
||||
(let loop ((chars (string->list str))
|
||||
(result '())
|
||||
(prev-was-space #f))
|
||||
(if (null? chars)
|
||||
(list->string (reverse result))
|
||||
(let ((char (car chars)))
|
||||
(if (char=? char #\space)
|
||||
(if prev-was-space
|
||||
;; Skip this space
|
||||
(loop (cdr chars) result #t)
|
||||
;; Keep this space
|
||||
(loop (cdr chars) (cons char result) #t))
|
||||
;; Not a space
|
||||
(loop (cdr chars) (cons char result) #f))))))
|
||||
|
||||
%% Helper function to extract chord names from markup, handling \altChord format
|
||||
#(define (extract-chord-names-from-markup markup)
|
||||
"Extract chord names from markup, handling complex structures like \altChord which produces 'B(Gm)' format"
|
||||
(let* ((raw-str (cond
|
||||
((string? markup) markup)
|
||||
((markup? markup) (markup->string markup))
|
||||
((pair? markup) (extract-chord-names-from-markup (car markup)))
|
||||
(else (format #f "~a" markup))))
|
||||
;; Remove all spaces
|
||||
(clean-str (string-delete #\space raw-str)))
|
||||
;; Check if this is an altChord format: "B(Gm)" or similar
|
||||
(if (string-index clean-str #\()
|
||||
;; Multiple chords: split by parentheses
|
||||
(let* ((open-paren (string-index clean-str #\())
|
||||
(close-paren (string-index clean-str #\)))
|
||||
(first-chord (substring clean-str 0 open-paren))
|
||||
(second-chord (if (and open-paren close-paren)
|
||||
(substring clean-str (+ open-paren 1) close-paren)
|
||||
"")))
|
||||
;; Format as:[B][(Gm)] - first chord normal, second in parens
|
||||
(string-append first-chord "][(" second-chord ")"))
|
||||
;; Single chord: return as is
|
||||
clean-str)))
|
||||
|
||||
%% Global state - shared across all engraver instances!
|
||||
#(define chordpro-syllables-collected '())
|
||||
#(define chordpro-chords-collected '())
|
||||
#(define chordpro-breaks-collected '())
|
||||
#(define chordpro-stanza-numbers '())
|
||||
%% Format: (moment verse-idx text direction) for inline text markers like repStart/repStop
|
||||
#(define chordpro-inline-texts-collected '())
|
||||
%%Track break moments to detect verse changes
|
||||
#(define chordpro-seen-break-moments '())
|
||||
%% Increments with each verse (each chordlyrics call)
|
||||
#(define chordpro-current-verse-index 0)
|
||||
%% Collected minor chords (lowercase German chords) for {define:} directives
|
||||
#(define chordpro-minor-chords-used '())
|
||||
%% Collected B chords (German B = English Bb) for {define:} directives
|
||||
#(define chordpro-b-chords-used '())
|
||||
%% Collected H chords (German H = English B) for {define:} directives
|
||||
#(define chordpro-h-chords-used '())
|
||||
%% Collected chords with accidentals (is/es) for {define:} directives
|
||||
#(define chordpro-accidental-chords-used '())
|
||||
|
||||
%% Configuration and metadata (set by layout_bottom.ily or song file)
|
||||
#(define chordpro-export-enabled #t)
|
||||
#(define chordpro-current-filename "output")
|
||||
#(define chordpro-header-title "Untitled")
|
||||
#(define chordpro-header-authors #f)
|
||||
|
||||
%% Write flag (ensures we only write once, not for each finalize call)
|
||||
#(define chordpro-file-written #f)
|
||||
|
||||
%% Helper function to format stanza label for ChordPro
|
||||
#(define (format-chordpro-stanza-label stanza-type stanza-numbers)
|
||||
"Generate ChordPro label based on stanza type and optional numbers"
|
||||
(let* ((has-numbers (and stanza-numbers (not (null? stanza-numbers))))
|
||||
(numbers-string (if has-numbers
|
||||
(string-join (map (lambda (n) (format #f "~a" n)) stanza-numbers) ", ")
|
||||
"")))
|
||||
(cond
|
||||
((eq? stanza-type 'ref)
|
||||
(if has-numbers
|
||||
(format #f (if (defined? 'refStringWithNumbers) refStringWithNumbers "Ref. ~a:") numbers-string)
|
||||
(if (defined? 'refString) refString "Ref.:")))
|
||||
((eq? stanza-type 'bridge)
|
||||
(if has-numbers
|
||||
(format #f (if (defined? 'bridgeStringWithNumbers) bridgeStringWithNumbers "Bridge ~a:") numbers-string)
|
||||
(if (defined? 'bridgeString) bridgeString "Bridge:")))
|
||||
(else #f))))
|
||||
|
||||
%% Single engraver in Score context
|
||||
#(define ChordPro_score_collector
|
||||
(lambda (context)
|
||||
(let ((pending-syllable #f)
|
||||
(this-verse-index #f))
|
||||
(make-engraver
|
||||
;; Initialize - called when engraver is created (once per \chordlyrics)
|
||||
((initialize engraver)
|
||||
;; Each \chordlyrics call creates a new Score, so this marks a new verse
|
||||
(when (> chordpro-current-verse-index 0)
|
||||
;; Reset break tracking for new verse
|
||||
(set! chordpro-seen-break-moments '()))
|
||||
;; Store the verse index for this instance
|
||||
(set! this-verse-index chordpro-current-verse-index)
|
||||
;; Increment global index for next verse
|
||||
(set! chordpro-current-verse-index (+ chordpro-current-verse-index 1)))
|
||||
|
||||
;; Event listeners
|
||||
(listeners
|
||||
;; LyricEvent from Lyrics context
|
||||
((lyric-event engraver event)
|
||||
(let ((text (ly:event-property event 'text))
|
||||
(moment (ly:context-current-moment context)))
|
||||
(when (string? text)
|
||||
;; On first lyric event for this engraver instance, capture the verse index
|
||||
(when (not this-verse-index)
|
||||
(set! this-verse-index chordpro-current-verse-index)
|
||||
(set! chordpro-current-verse-index (+ chordpro-current-verse-index 1)))
|
||||
|
||||
;; Save previous syllable if any (it had no hyphen)
|
||||
(when pending-syllable
|
||||
(set! chordpro-syllables-collected
|
||||
(cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable))
|
||||
chordpro-syllables-collected)))
|
||||
;; Store new syllable as pending (with THIS instance's verse index)
|
||||
(set! pending-syllable (list moment text this-verse-index)))))
|
||||
|
||||
;; HyphenEvent from Lyrics context
|
||||
((hyphen-event engraver event)
|
||||
(when pending-syllable
|
||||
(set! chordpro-syllables-collected
|
||||
(cons (list (car pending-syllable) (cadr pending-syllable) #t (caddr pending-syllable))
|
||||
chordpro-syllables-collected))
|
||||
(set! pending-syllable #f)))
|
||||
|
||||
;; BreakEvent - store break moment
|
||||
((break-event engraver event)
|
||||
(let ((moment (ly:context-current-moment context)))
|
||||
|
||||
;; Store break with this instance's verse index
|
||||
(set! chordpro-breaks-collected
|
||||
(cons (cons moment this-verse-index) chordpro-breaks-collected)))))
|
||||
|
||||
;; Acknowledge grobs from child contexts
|
||||
(acknowledgers
|
||||
;; StanzaNumber grobs to extract stanza type and text
|
||||
((stanza-number-interface engraver grob source-engraver)
|
||||
(let* ((details (ly:grob-property grob 'details '()))
|
||||
(custom-realstanza (ly:assoc-get 'custom-realstanza details #f))
|
||||
(stanza-type (ly:assoc-get 'custom-stanza-type details 'verse))
|
||||
(stanza-numbers (ly:assoc-get 'custom-stanza-numbers details '()))
|
||||
;; Check for custom inline text (e.g., repStart/repStop with direction)
|
||||
(custom-inline-text (ly:assoc-get 'custom-inline-text details #f))
|
||||
(custom-inline-direction (ly:assoc-get 'custom-inline-direction details CENTER))
|
||||
;; Try to read stanza text from multiple sources:
|
||||
;; 1. From the grob's text property
|
||||
(stanza-text-from-grob (ly:grob-property grob 'text #f))
|
||||
;; 2. From the Lyrics context's stanza property
|
||||
(lyrics-context (ly:translator-context source-engraver))
|
||||
(stanza-text-from-context (if lyrics-context
|
||||
(ly:context-property lyrics-context 'stanza #f)
|
||||
#f))
|
||||
;; Use context property if available, otherwise grob property
|
||||
(stanza-markup (or stanza-text-from-context stanza-text-from-grob))
|
||||
;; For ref/bridge, always use format-chordpro-stanza-label
|
||||
;; For verse, extract from markup (includes roman numerals if \romanStanza was used)
|
||||
(stanza-text (if (or (eq? stanza-type 'ref) (eq? stanza-type 'bridge))
|
||||
(format-chordpro-stanza-label stanza-type stanza-numbers)
|
||||
(if (markup? stanza-markup)
|
||||
(markup->string stanza-markup)
|
||||
(if stanza-markup
|
||||
(format #f "~a" stanza-markup)
|
||||
#f))))
|
||||
(existing (assoc this-verse-index chordpro-stanza-numbers))
|
||||
(moment (ly:context-current-moment (ly:translator-context source-engraver)))
|
||||
(direction (ly:grob-property grob 'direction CENTER)))
|
||||
|
||||
;; If custom-inline-text is set, always collect it as inline text (regardless of realstanza)
|
||||
;; This allows repStart/repStop to be collected even when combined with real stanza numbers
|
||||
(when custom-inline-text
|
||||
(set! chordpro-inline-texts-collected
|
||||
(cons (list moment this-verse-index custom-inline-text custom-inline-direction)
|
||||
chordpro-inline-texts-collected)))
|
||||
|
||||
;; If this is NOT a real stanza marker (custom-realstanza not set or ##f),
|
||||
;; collect it as inline text with direction info
|
||||
(when (and (not custom-realstanza) (not custom-inline-text))
|
||||
(when stanza-text ; Only if there's text to display
|
||||
(set! chordpro-inline-texts-collected
|
||||
(cons (list moment this-verse-index stanza-text direction)
|
||||
chordpro-inline-texts-collected))))
|
||||
|
||||
;; Store or update stanza info for this verse (only if it's a real stanza marker)
|
||||
;; Entry format: (verse-idx stanza-text stanza-type realstanza-flag)
|
||||
(when custom-realstanza
|
||||
(if existing
|
||||
;; Update existing entry with type and text if available
|
||||
;; IMPORTANT: Don't overwrite realstanza=##t markers and their text
|
||||
(let* ((existing-text (cadr existing))
|
||||
(existing-type (caddr existing))
|
||||
(existing-realstanza (if (> (length existing) 3) (cadddr existing) #f)))
|
||||
(set! chordpro-stanza-numbers
|
||||
(map (lambda (entry)
|
||||
(if (= (car entry) this-verse-index)
|
||||
(list (car entry)
|
||||
;; If existing entry is a real stanza, don't overwrite text
|
||||
;; Otherwise, use new text if available
|
||||
(if existing-realstanza
|
||||
existing-text
|
||||
(or stanza-text existing-text))
|
||||
;; Update type only if custom-realstanza is set
|
||||
(if custom-realstanza stanza-type existing-type)
|
||||
;; Preserve ##t realstanza flag
|
||||
(or existing-realstanza custom-realstanza))
|
||||
entry))
|
||||
chordpro-stanza-numbers)))
|
||||
;; Create new entry with type, text, and realstanza flag
|
||||
(set! chordpro-stanza-numbers
|
||||
(cons (list this-verse-index stanza-text stanza-type custom-realstanza)
|
||||
chordpro-stanza-numbers)))))) ; closes set!, if, when, stanza-number-interface
|
||||
|
||||
;; ChordName grobs from ChordNames context
|
||||
;; Store grob reference - visibility will be recorded by ChordPro_chord_visibility_recorder
|
||||
((chord-name-interface engraver grob source-engraver)
|
||||
(let* ((moment (ly:context-current-moment context))
|
||||
;; Get details property to check for altChord
|
||||
(details (ly:grob-property grob 'details '()))
|
||||
(alt-main-name (assoc-get 'alt-chord-main-name details #f))
|
||||
(alt-alt-name (assoc-get 'alt-chord-alt-name details #f))
|
||||
;; Extract chord name
|
||||
(chord-name-final
|
||||
(if (and alt-main-name alt-alt-name)
|
||||
;; This is an altChord - use the pre-extracted names
|
||||
(let ((main (track-and-return-chord alt-main-name))
|
||||
(alt (track-and-return-chord alt-alt-name)))
|
||||
;; Check if main is empty - if so, only output alt in parens
|
||||
(if (string-null? main)
|
||||
(string-append "[(" alt ")]") ; Only alt chord: [(D7)]
|
||||
;; Format as: [B][(Gm)] (complete with all brackets)
|
||||
(string-append "[" main "][(" alt ")]")))
|
||||
;; Normal chord - extract from markup text
|
||||
(let* ((chord-text (ly:grob-property grob 'text))
|
||||
(chord-names-str (extract-chord-names-from-markup chord-text))
|
||||
;; Check if it contains "][(": multiple chords (shouldn't happen anymore)
|
||||
(has-bracket (string-index chord-names-str #\])))
|
||||
(if has-bracket
|
||||
;; Multiple chords from old logic: manually split and process
|
||||
(let* ((bracket-pos (string-index chord-names-str #\]))
|
||||
(first-part (substring chord-names-str 0 bracket-pos))
|
||||
(rest (substring chord-names-str bracket-pos))
|
||||
(open-pos (string-index rest #\())
|
||||
(close-pos (string-index rest #\)))
|
||||
(second-part (if (and open-pos close-pos)
|
||||
(substring rest (+ open-pos 1) close-pos)
|
||||
""))
|
||||
(first-converted (track-and-return-chord first-part))
|
||||
(second-converted (track-and-return-chord second-part)))
|
||||
(string-append first-converted "][(" second-converted ")"))
|
||||
;; Single chord: just track and return original
|
||||
(track-and-return-chord chord-names-str))))))
|
||||
;; Store grob reference along with chord data (unless empty)
|
||||
;; Format: (moment chord-name verse-index grob)
|
||||
;; Filter out completely empty chords, but convert ][(X) to [(X)]
|
||||
(let ((processed-chord-name
|
||||
(cond
|
||||
;; Empty chord
|
||||
((or (string-null? chord-name-final)
|
||||
(string=? chord-name-final "")
|
||||
(string=? chord-name-final "]["))
|
||||
#f) ; Filter out
|
||||
;; Pattern ][(X) - empty main, only alt in parens: convert to [(X)]
|
||||
((string-prefix? "][(" chord-name-final)
|
||||
;; ][(D7) → [(D7)]
|
||||
(let* ((inner (substring chord-name-final 3 (- (string-length chord-name-final) 1))))
|
||||
(string-append "[(" inner ")]")))
|
||||
;; Normal chord
|
||||
(else chord-name-final))))
|
||||
(when processed-chord-name
|
||||
(set! chordpro-chords-collected
|
||||
(cons (list moment processed-chord-name this-verse-index grob) chordpro-chords-collected))))))
|
||||
|
||||
;; LyricText grobs to get stanza number
|
||||
((lyric-syllable-interface engraver grob source-engraver)
|
||||
(let* ((stanza-grob (ly:grob-property grob 'stanza #f))
|
||||
;; Get the Lyrics context from the source engraver
|
||||
(lyrics-context (ly:translator-context source-engraver))
|
||||
(stanza-context (if lyrics-context
|
||||
(ly:context-property lyrics-context 'stanza #f)
|
||||
#f))
|
||||
(stanza-value (or stanza-grob stanza-context)))
|
||||
|
||||
(when stanza-value
|
||||
;; Only update existing stanza entries (don't create new ones)
|
||||
;; New entries should only be created by stanza-number-interface
|
||||
(let* ((existing (assoc this-verse-index chordpro-stanza-numbers))
|
||||
(existing-text (if existing (cadr existing) #f))
|
||||
(stanza-text (if (markup? stanza-value)
|
||||
(markup->string stanza-value)
|
||||
(format #f "~a" stanza-value))))
|
||||
;; Only update if entry exists and existing text is empty/false and new text is non-empty
|
||||
(when (and existing
|
||||
(not (and (string? existing-text) (not (string-null? existing-text))))
|
||||
(string? stanza-text)
|
||||
(not (string-null? stanza-text)))
|
||||
;; Update existing entry with text (keep type and realstanza flag)
|
||||
(set! chordpro-stanza-numbers
|
||||
(map (lambda (entry)
|
||||
(if (= (car entry) this-verse-index)
|
||||
(list (car entry)
|
||||
(or existing-text stanza-text) ; Keep existing text if present
|
||||
(caddr entry) ; Keep stanza-type
|
||||
(if (> (length entry) 3) (cadddr entry) #f)) ; Keep realstanza-flag if exists
|
||||
entry))
|
||||
chordpro-stanza-numbers))))))) ; schließt lyric-syllable-interface
|
||||
) ; schließt acknowledgers
|
||||
;; End of timestep
|
||||
((stop-translation-timestep engraver)
|
||||
(when pending-syllable
|
||||
(set! chordpro-syllables-collected
|
||||
(cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable))
|
||||
chordpro-syllables-collected))
|
||||
(set! pending-syllable #f)))
|
||||
|
||||
;; Finalize - just write debug, don't filter chords yet
|
||||
;; (Filtering happens in chordpro-write-from-engraver-data where grob properties are final)
|
||||
((finalize engraver)
|
||||
;; Save any remaining pending syllable
|
||||
(when pending-syllable
|
||||
(set! chordpro-syllables-collected
|
||||
(cons (list (car pending-syllable) (cadr pending-syllable) #f (caddr pending-syllable))
|
||||
chordpro-syllables-collected))
|
||||
(set! pending-syllable #f))
|
||||
)))))
|
||||
|
||||
%% Helper functions to format and write ChordPro
|
||||
#(define (chordpro-write-from-engraver-data num-verses)
|
||||
"Write ChordPro file from collected engraver data"
|
||||
(let* ((filename (if (defined? 'chordpro-current-filename)
|
||||
chordpro-current-filename
|
||||
"output"))
|
||||
(output-file (string-append filename ".cho"))
|
||||
;; Reverse all lists (they were collected in reverse order)
|
||||
(syllables (reverse chordpro-syllables-collected))
|
||||
(chords (reverse chordpro-chords-collected))
|
||||
(breaks (reverse chordpro-breaks-collected)))
|
||||
|
||||
(with-output-to-file output-file
|
||||
(lambda ()
|
||||
;; Write metadata
|
||||
(display (format #f "{title: ~a}\n"
|
||||
(if (defined? 'chordpro-header-title)
|
||||
chordpro-header-title
|
||||
"Untitled")))
|
||||
(when (and (defined? 'chordpro-header-authors) chordpro-header-authors)
|
||||
(display (format #f "{artist: ~a}\n"
|
||||
(format-chordpro-authors chordpro-header-authors))))
|
||||
|
||||
;; Write {define:} directives for all used minor chords
|
||||
(unless (null? chordpro-minor-chords-used)
|
||||
(newline)
|
||||
(for-each
|
||||
(lambda (minor-chord)
|
||||
;; Convert minor chord to major form for the definition
|
||||
(let ((major-form (german-minor-to-major-form minor-chord)))
|
||||
(display (format #f "{define: ~a copy ~a}\n" minor-chord major-form))))
|
||||
(reverse chordpro-minor-chords-used)))
|
||||
|
||||
;; Write {define:} directives for all used B chords (German B = English Bb)
|
||||
(unless (null? chordpro-b-chords-used)
|
||||
(for-each
|
||||
(lambda (b-chord)
|
||||
;; Convert B/b to Bb/Bbm form for the definition
|
||||
(let ((bb-form (german-b-to-bb-form b-chord)))
|
||||
(display (format #f "{define: ~a copy ~a}\n" b-chord bb-form))))
|
||||
(reverse chordpro-b-chords-used)))
|
||||
|
||||
;; Write {define:} directives for all used H chords (German H = English B)
|
||||
(unless (null? chordpro-h-chords-used)
|
||||
(for-each
|
||||
(lambda (h-chord)
|
||||
;; Convert H/h to B/Bm form for the definition
|
||||
(let ((b-form (german-h-to-b-form h-chord)))
|
||||
(display (format #f "{define: ~a copy ~a}\n" h-chord b-form))))
|
||||
(reverse chordpro-h-chords-used)))
|
||||
|
||||
;; Write {define:} directives for chords with accidentals (is/es -> #/b)
|
||||
(unless (null? chordpro-accidental-chords-used)
|
||||
(for-each
|
||||
(lambda (accidental-chord)
|
||||
;; Convert German accidentals to international format
|
||||
(let ((intl-form (german-accidentals-to-international accidental-chord)))
|
||||
(display (format #f "{define: ~a copy ~a}\n" accidental-chord intl-form))))
|
||||
(reverse chordpro-accidental-chords-used)))
|
||||
|
||||
(newline)
|
||||
|
||||
;; Write each verse in reverse order (they were collected backwards)
|
||||
(let loop ((verse-idx (- num-verses 1)))
|
||||
(when (>= verse-idx 0)
|
||||
;; Get syllables, chords and breaks for this verse
|
||||
(let* ((verse-syllables (filter (lambda (s) (= (cadddr s) verse-idx)) syllables))
|
||||
(verse-chords-raw (filter (lambda (c)
|
||||
(and (list? c)
|
||||
(>= (length c) 3)
|
||||
(= (caddr c) verse-idx)))
|
||||
chords))
|
||||
;; Simple filtering: remove repeated consecutive chords
|
||||
(verse-chords (let filter-repeats ((chords-left verse-chords-raw)
|
||||
(last-chord #f)
|
||||
(result '()))
|
||||
(if (null? chords-left)
|
||||
(reverse result)
|
||||
(let* ((chord (car chords-left))
|
||||
(chord-name (cadr chord)))
|
||||
(if (equal? chord-name last-chord)
|
||||
;; Skip repeated chord
|
||||
(filter-repeats (cdr chords-left) last-chord result)
|
||||
;; Include new chord
|
||||
(filter-repeats (cdr chords-left) chord-name
|
||||
(cons (list (car chord) chord-name (caddr chord)) result)))))))
|
||||
(verse-breaks (filter (lambda (b) (= (cdr b) verse-idx)) breaks))
|
||||
(verse-inline-texts (filter (lambda (r) (= (cadr r) verse-idx))
|
||||
(reverse chordpro-inline-texts-collected)))
|
||||
;; Get stanza info (number, type, and realstanza flag) for this verse
|
||||
(stanza-entry (find (lambda (s) (= (car s) verse-idx)) chordpro-stanza-numbers))
|
||||
(stanza-num (if stanza-entry (cadr stanza-entry) #f))
|
||||
(stanza-type (if stanza-entry (caddr stanza-entry) 'verse))
|
||||
(realstanza (if stanza-entry (cadddr stanza-entry) #f))
|
||||
;; Determine ChordPro directive based on type
|
||||
(start-directive (cond
|
||||
((eq? stanza-type 'ref) "start_of_chorus")
|
||||
((eq? stanza-type 'bridge) "start_of_bridge")
|
||||
(else "start_of_verse")))
|
||||
(end-directive (cond
|
||||
((eq? stanza-type 'ref) "end_of_chorus")
|
||||
((eq? stanza-type 'bridge) "end_of_bridge")
|
||||
(else "end_of_verse"))))
|
||||
|
||||
(when (not (null? verse-syllables))
|
||||
;; If realstanza is ##t, output with ChordPro directives
|
||||
;; Otherwise, just output the text (e.g., for repStartWithTag/repStopWithTag)
|
||||
(if realstanza
|
||||
(begin
|
||||
(if (and stanza-num (not (string-null? stanza-num)))
|
||||
(display (format #f "{~a: label=\"~a\"}\n" start-directive stanza-num))
|
||||
(display (format #f "{~a}\n" start-directive)))
|
||||
(display (format-verse-as-chordpro verse-syllables verse-chords verse-breaks verse-inline-texts))
|
||||
(display (format #f "\n{~a}\n\n" end-directive)))
|
||||
(begin
|
||||
;; For non-real stanzas, just output stanza marker as comment if present
|
||||
(when (and stanza-num (not (string-null? stanza-num)))
|
||||
(display (format #f "# ~a\n" stanza-num)))
|
||||
(display (format-verse-as-chordpro verse-syllables verse-chords verse-breaks verse-inline-texts))
|
||||
(display "\n\n"))))
|
||||
|
||||
(loop (- verse-idx 1)))))))
|
||||
|
||||
))
|
||||
|
||||
#(define (format-verse-as-chordpro syllables chords breaks inline-texts)
|
||||
"Format one verse as ChordPro text with line breaks.
|
||||
Chords are placed at syllable boundaries, not word boundaries.
|
||||
Inline texts (𝄆 𝄇 etc.) are inserted based on their direction property."
|
||||
(let* (;; Get break moments
|
||||
(break-moments (sort (map (lambda (b) (ly:moment-main (car b))) breaks) <))
|
||||
;; Map each chord to the nearest following syllable
|
||||
(chord-to-syllable-map (map-chords-to-syllables chords syllables))
|
||||
;; Sort inline texts by moment
|
||||
(sorted-inline-texts (sort inline-texts (lambda (a b) (ly:moment<? (car a) (car b)))))
|
||||
;; Build formatted output
|
||||
(lines '())
|
||||
(current-line '())
|
||||
(current-word-parts '())
|
||||
(pending-word-suffix-chords '()) ; Collect suffix chords during word building
|
||||
(word-start-moment #f))
|
||||
|
||||
;; Process each syllable
|
||||
(let process-syllables ((syls-left syllables) (syl-idx 0) (breaks-left break-moments) (inlines-left sorted-inline-texts) (pending-line-chords '()))
|
||||
(if (null? syls-left)
|
||||
;; Finish last word and line
|
||||
(begin
|
||||
(unless (null? current-word-parts)
|
||||
;; Append pending suffix chords to the last word part
|
||||
(when (not (null? pending-word-suffix-chords))
|
||||
(let ((last-part (car current-word-parts))
|
||||
(suffix-str (string-concatenate (reverse pending-word-suffix-chords))))
|
||||
(set! current-word-parts (cons (string-append last-part suffix-str) (cdr current-word-parts)))
|
||||
(set! pending-word-suffix-chords '())))
|
||||
(set! current-line (cons (string-concatenate (reverse current-word-parts)) current-line)))
|
||||
(unless (null? current-line)
|
||||
(set! lines (cons (reverse current-line) lines))))
|
||||
|
||||
;; Process next syllable
|
||||
(let* ((syl-entry (car syls-left))
|
||||
(syl-moment (ly:moment-main (car syl-entry)))
|
||||
(syl-text-raw (cadr syl-entry))
|
||||
;; Normalize: treat whitespace-only strings as empty (lyric extenders come as spaces)
|
||||
(syl-text (if (and (string? syl-text-raw)
|
||||
(not (string-null? syl-text-raw))
|
||||
(string-every char-set:whitespace syl-text-raw))
|
||||
""
|
||||
syl-text-raw))
|
||||
(has-hyphen (caddr syl-entry))
|
||||
(rest-syls (cdr syls-left))
|
||||
;; Find chords for this syllable position (including extenders!)
|
||||
(syl-chords (filter (lambda (cm) (= (caddr cm) syl-idx)) chord-to-syllable-map))
|
||||
;; Separate chords into prefix (before/on syllable) and suffix (after syllable)
|
||||
;; Separate chords into prefix (before/on syllable) and suffix (after syllable)
|
||||
(prefix-chords (filter (lambda (c) (<= (ly:moment-main (car c)) syl-moment)) syl-chords))
|
||||
(suffix-chords-all (filter (lambda (c) (> (ly:moment-main (car c)) syl-moment)) syl-chords))
|
||||
;; Filter suffix chords: only keep those where NO line break exists between syllable and chord
|
||||
;; If a break is between the syllable and chord, the chord belongs to the next line
|
||||
(suffix-chords (filter (lambda (c)
|
||||
(let ((chord-moment (ly:moment-main (car c))))
|
||||
;; Keep chord if no break exists, or if break is not between syl and chord
|
||||
(or (null? breaks-left)
|
||||
(let ((next-break (car breaks-left)))
|
||||
;; Only keep if break is AFTER the chord (or before/at syllable)
|
||||
;; Reject if: syl-moment < next-break <= chord-moment
|
||||
(not (and (> next-break syl-moment)
|
||||
(<= next-break chord-moment)))))))
|
||||
suffix-chords-all))
|
||||
;; Collect chords that were filtered out - they belong to the next line
|
||||
(next-line-chords (filter (lambda (c)
|
||||
(let ((chord-moment (ly:moment-main (car c))))
|
||||
(and (not (null? breaks-left))
|
||||
(let ((next-break (car breaks-left)))
|
||||
(and (> next-break syl-moment)
|
||||
(<= next-break chord-moment))))))
|
||||
suffix-chords-all))
|
||||
;; Create chord prefix: add space after chord if it plays on a rest (before syllable)
|
||||
(chord-prefix (if (null? prefix-chords)
|
||||
""
|
||||
(string-join
|
||||
(map (lambda (c)
|
||||
(let* ((chord-moment (ly:moment-main (car c)))
|
||||
(chord-name (cadr c))
|
||||
;; Check if chord plays before syllable (on a rest)
|
||||
(on-rest? (< chord-moment syl-moment))
|
||||
;; Check if chord already has brackets
|
||||
(has-brackets (string-prefix? "[" chord-name)))
|
||||
(if has-brackets
|
||||
;; Already has brackets - just add space if needed
|
||||
(if on-rest?
|
||||
(string-append chord-name " ")
|
||||
chord-name)
|
||||
;; Add brackets
|
||||
(if on-rest?
|
||||
(string-append "[" chord-name "] ")
|
||||
(string-append "[" chord-name "]")))))
|
||||
prefix-chords)
|
||||
"")))
|
||||
;; Create chord suffix for chords that play after the syllable (on rests)
|
||||
(chord-suffix (if (null? suffix-chords)
|
||||
""
|
||||
(string-join
|
||||
(map (lambda (c)
|
||||
(let ((chord-name (cadr c)))
|
||||
;; Check if chord already has brackets (e.g., "[(D7)]")
|
||||
(if (string-prefix? "[" chord-name)
|
||||
chord-name ; Already has brackets
|
||||
(string-append "[" chord-name "]"))))
|
||||
suffix-chords)
|
||||
"")))
|
||||
;; Check for line break
|
||||
(next-syl-moment (if (null? rest-syls) 999999 (ly:moment-main (car (car rest-syls)))))
|
||||
(break-here (and (not (null? breaks-left))
|
||||
(let ((next-break (car breaks-left)))
|
||||
(and (> next-break syl-moment)
|
||||
(<= next-break next-syl-moment))))))
|
||||
|
||||
;; Check for inline texts at this syllable position
|
||||
(let* ((inline-result
|
||||
(let collect-inlines ((inls inlines-left) (collected '()))
|
||||
(if (or (null? inls)
|
||||
(let ((inl-entry (car inls)))
|
||||
(> (ly:moment-main (car inl-entry)) syl-moment)))
|
||||
(list (reverse collected) inls)
|
||||
(collect-inlines (cdr inls) (cons (car inls) collected)))))
|
||||
(inlines-to-insert (car inline-result))
|
||||
(new-inlines-left (cadr inline-result))
|
||||
;; Separate by direction: LEFT texts go before, RIGHT texts go after
|
||||
(before-texts (filter (lambda (i) (eqv? (cadddr i) LEFT)) inlines-to-insert))
|
||||
(after-texts (filter (lambda (i) (eqv? (cadddr i) RIGHT)) inlines-to-insert)))
|
||||
|
||||
;; If this is the start of a new line and we have pending chords from the previous line
|
||||
(when (and (null? current-line) (not (null? pending-line-chords)))
|
||||
;; If we're continuing a word (current-word-parts not empty), add chords as infix
|
||||
;; Otherwise add them as a separate word-like element
|
||||
(if (not (null? current-word-parts))
|
||||
;; Add pending chords as infix to the last word part
|
||||
(let* ((last-part (car current-word-parts))
|
||||
(rest-parts (cdr current-word-parts))
|
||||
(pending-chord-str (string-join
|
||||
(map (lambda (c)
|
||||
(let ((chord-name (cadr c)))
|
||||
(if (string-prefix? "[" chord-name)
|
||||
chord-name ; Already has brackets
|
||||
(string-append "[" chord-name "]"))))
|
||||
pending-line-chords)
|
||||
"")))
|
||||
(set! current-word-parts (cons (string-append last-part pending-chord-str) rest-parts)))
|
||||
;; No word continuation - add as separate element
|
||||
(let ((pending-chord-str (string-join
|
||||
(map (lambda (c)
|
||||
(let ((chord-name (cadr c)))
|
||||
(if (string-prefix? "[" chord-name)
|
||||
chord-name ; Already has brackets
|
||||
(string-append "[" chord-name "]"))))
|
||||
pending-line-chords)
|
||||
"")))
|
||||
(set! current-line (cons pending-chord-str current-line)))))
|
||||
|
||||
;; Insert texts that should appear BEFORE the syllable (direction = LEFT)
|
||||
(for-each
|
||||
(lambda (inline-text)
|
||||
(set! current-line (cons (caddr inline-text) current-line)))
|
||||
before-texts)
|
||||
|
||||
;; Track word start
|
||||
(when (null? current-word-parts)
|
||||
(set! word-start-moment syl-moment))
|
||||
|
||||
;; Add text to current word only if syllable is not empty (not a lyric extender _)
|
||||
;; Handle chords: if we're continuing a word (current-word-parts not empty),
|
||||
;; prefix chords should be inserted between syllables as infixes (without trailing space)
|
||||
(unless (string-null? syl-text)
|
||||
(if (null? current-word-parts)
|
||||
;; First syllable of word: use prefix as normal
|
||||
(set! current-word-parts (cons (string-append chord-prefix syl-text) current-word-parts))
|
||||
;; Continuation of word: insert prefix chord between previous syllable and this one
|
||||
(begin
|
||||
;; Append prefix chord to the LAST syllable (strip trailing space from chord-prefix for infix use)
|
||||
(unless (string-null? chord-prefix)
|
||||
(let* ((last-part (car current-word-parts))
|
||||
(rest-parts (cdr current-word-parts))
|
||||
;; Remove trailing space from chord-prefix if present
|
||||
(chord-infix (if (string-suffix? " " chord-prefix)
|
||||
(substring chord-prefix 0 (- (string-length chord-prefix) 1))
|
||||
chord-prefix)))
|
||||
(set! current-word-parts (cons (string-append last-part chord-infix) rest-parts))))
|
||||
;; Add current syllable
|
||||
(set! current-word-parts (cons syl-text current-word-parts)))))
|
||||
|
||||
;; Always collect suffix chords (even from extenders), they'll be output at word end
|
||||
(unless (string-null? chord-suffix)
|
||||
(set! pending-word-suffix-chords (cons chord-suffix pending-word-suffix-chords)))
|
||||
|
||||
;; Complete word only if: no hyphen AND syllable has text (not an extender)
|
||||
(when (and (not has-hyphen) (not (string-null? syl-text)))
|
||||
(if (null? current-word-parts)
|
||||
;; No word parts (shouldn't happen) - just output suffix chords if any
|
||||
(unless (null? pending-word-suffix-chords)
|
||||
(set! current-line (cons (string-concatenate (reverse pending-word-suffix-chords)) current-line))
|
||||
(set! pending-word-suffix-chords '()))
|
||||
;; Normal word completion with all collected suffix chords
|
||||
(let ((word-with-suffix
|
||||
(if (null? pending-word-suffix-chords)
|
||||
(string-concatenate (reverse current-word-parts))
|
||||
(string-append
|
||||
(string-concatenate (reverse current-word-parts))
|
||||
(string-concatenate (reverse pending-word-suffix-chords))))))
|
||||
(set! current-line (cons word-with-suffix current-line))
|
||||
(set! current-word-parts '())
|
||||
(set! pending-word-suffix-chords '()))))
|
||||
(for-each
|
||||
(lambda (inline-text)
|
||||
(set! current-line (cons (caddr inline-text) current-line)))
|
||||
after-texts)
|
||||
|
||||
;; If break here, complete line (word parts continue on next line)
|
||||
(if break-here
|
||||
(begin
|
||||
(set! lines (cons (reverse current-line) lines))
|
||||
(set! current-line '())
|
||||
(process-syllables rest-syls (+ syl-idx 1) (cdr breaks-left) new-inlines-left next-line-chords))
|
||||
(process-syllables rest-syls (+ syl-idx 1) breaks-left new-inlines-left '())))))
|
||||
|
||||
;; Format all lines and normalize multiple spaces
|
||||
(string-join
|
||||
(map (lambda (line-words)
|
||||
(let ((line (string-join line-words " ")))
|
||||
(normalize-spaces line)))
|
||||
(reverse lines))
|
||||
"\n"))))
|
||||
|
||||
#(define (map-chords-to-syllables chords syllables)
|
||||
"For each chord, find the nearest following syllable.
|
||||
If no following syllable within tolerance, use the last preceding syllable.
|
||||
Returns list of (chord-moment chord-name syllable-index)"
|
||||
(let ((tolerance (ly:make-moment 1/4)))
|
||||
(filter-map
|
||||
(lambda (chord-entry)
|
||||
(let* ((chord-moment (car chord-entry))
|
||||
(chord-name (cadr chord-entry))
|
||||
;; Find syllables that start AT or AFTER this chord (within tolerance)
|
||||
(candidate-syllables-forward
|
||||
(filter-map
|
||||
(lambda (syl-entry syl-idx)
|
||||
(let* ((syl-moment (car syl-entry))
|
||||
(diff (ly:moment-sub syl-moment chord-moment)))
|
||||
;; Syllable must start at or after chord, within tolerance
|
||||
(if (and (not (ly:moment<? diff (ly:make-moment 0))) ; diff >= 0
|
||||
(ly:moment<=? diff tolerance))
|
||||
(list diff syl-idx)
|
||||
#f)))
|
||||
syllables
|
||||
(iota (length syllables))))) ; syllable indices
|
||||
|
||||
;; If no forward match, try to find the last syllable BEFORE the chord
|
||||
(if (not (null? candidate-syllables-forward))
|
||||
;; Pick the closest following syllable (smallest diff)
|
||||
(let* ((sorted (sort candidate-syllables-forward (lambda (a b) (ly:moment<? (car a) (car b)))))
|
||||
(best (car sorted))
|
||||
(best-syl-idx (cadr best)))
|
||||
(list chord-moment chord-name best-syl-idx))
|
||||
;; No following syllable - find last preceding syllable
|
||||
(let ((preceding-syllables
|
||||
(filter-map
|
||||
(lambda (syl-entry syl-idx)
|
||||
(let* ((syl-moment (car syl-entry))
|
||||
(diff (ly:moment-sub chord-moment syl-moment)))
|
||||
;; Chord must come after syllable (diff > 0)
|
||||
(if (ly:moment<? (ly:make-moment 0) diff)
|
||||
(list diff syl-idx syl-moment)
|
||||
#f)))
|
||||
syllables
|
||||
(iota (length syllables)))))
|
||||
(if (null? preceding-syllables)
|
||||
#f ; No syllables at all - skip this chord
|
||||
;; Pick the latest preceding syllable (smallest diff = closest before chord)
|
||||
(let* ((sorted (sort preceding-syllables (lambda (a b) (ly:moment<? (car a) (car b)))))
|
||||
(best (car sorted))
|
||||
(best-syl-idx (cadr best)))
|
||||
(list chord-moment chord-name best-syl-idx)))))))
|
||||
chords)))
|
||||
|
||||
#(define (join-syllables-into-words syllables)
|
||||
"Join syllables into words based on hyphen flags"
|
||||
;; syllables structure: (moment text has-hyphen verse-idx)
|
||||
(let ((result '())
|
||||
(current-word-parts '())
|
||||
(word-start-moment #f))
|
||||
(for-each
|
||||
(lambda (syl-entry)
|
||||
(let* ((moment (car syl-entry))
|
||||
(text (cadr syl-entry))
|
||||
(has-hyphen (caddr syl-entry)))
|
||||
;; Track the moment of the first syllable of each word
|
||||
(when (null? current-word-parts)
|
||||
(set! word-start-moment moment))
|
||||
|
||||
;; Add syllable part to current word
|
||||
(set! current-word-parts (cons text current-word-parts))
|
||||
|
||||
;; If no hyphen after this syllable, the word is complete
|
||||
(unless has-hyphen
|
||||
(let ((complete-word (string-concatenate (reverse current-word-parts))))
|
||||
(set! result (cons (cons word-start-moment complete-word) result)))
|
||||
(set! current-word-parts '()))))
|
||||
syllables)
|
||||
|
||||
;; Return words in correct order
|
||||
(reverse result)))
|
||||
|
||||
#(define (find-chord-at-moment chords moment)
|
||||
"Find chord at or close to the given syllable moment"
|
||||
;; chords structure: (moment name verse-idx)
|
||||
;; Strategy: Find the CLOSEST chord that comes AT or AFTER the word start
|
||||
;; This way each chord is only matched to the nearest preceding word
|
||||
(let ((tolerance (ly:make-moment 1/4))) ; Allow chord up to 1/4 after word start
|
||||
(let loop ((remaining chords) (best-match #f) (best-diff #f))
|
||||
(cond
|
||||
((null? remaining) best-match)
|
||||
(else
|
||||
(let* ((chord-entry (car remaining))
|
||||
(chord-moment (car chord-entry))
|
||||
(chord-name (cadr chord-entry))
|
||||
(diff (ly:moment-sub chord-moment moment))) ; positive if chord is after word
|
||||
;; Only consider chords that are AT or AFTER the word start (diff >= 0)
|
||||
;; and within tolerance
|
||||
(let ((valid (and (not (ly:moment<? diff (ly:make-moment 0))) ; diff >= 0
|
||||
(ly:moment<=? diff tolerance))))
|
||||
(if (and valid
|
||||
(or (not best-diff)
|
||||
(ly:moment<? diff best-diff))) ; prefer closest (smallest diff)
|
||||
(loop (cdr remaining) chord-name diff)
|
||||
(loop (cdr remaining) best-match best-diff)))))))))
|
||||
|
||||
#(define (ly:moment=? a b)
|
||||
"Check if two moments are equal"
|
||||
(and (not (ly:moment<? a b))
|
||||
(not (ly:moment<? b a))))
|
||||
|
||||
#(define (ly:moment-abs m)
|
||||
"Get absolute value of moment"
|
||||
(if (ly:moment<? m (ly:make-moment 0))
|
||||
(ly:moment-sub (ly:make-moment 0) m)
|
||||
m))
|
||||
|
||||
#(define (ly:moment<=? m1 m2)
|
||||
"Check if m1 <= m2"
|
||||
(or (ly:moment<? m1 m2)
|
||||
(ly:moment=? m1 m2)))
|
||||
|
||||
#(define (ly:moment-add m1 m2)
|
||||
"Add two moments"
|
||||
(ly:moment-sub m1 (ly:moment-sub (ly:make-moment 0) m2)))
|
||||
|
||||
#(define (format-chordpro-authors authors)
|
||||
"Format authors list for ChordPro"
|
||||
(cond
|
||||
((list? authors)
|
||||
(string-join
|
||||
(filter (lambda (s) (not (string-null? s)))
|
||||
(map (lambda (author-info)
|
||||
(cond
|
||||
((pair? author-info) (car author-info))
|
||||
((string? author-info) author-info)
|
||||
(else "")))
|
||||
authors))
|
||||
", "))
|
||||
(else "")))
|
||||
|
||||
%% Define markup command for delayed ChordPro write BEFORE modifying TEXT_PAGES
|
||||
%% Uses delay-stencil-evaluation to write after all engraver data is collected
|
||||
#(define-markup-command (chordpro-delayed-write layout props)
|
||||
()
|
||||
#:category other
|
||||
"Invisible markup that writes ChordPro file during stencil evaluation (after all engraver data is collected)"
|
||||
;; We use a delayed stencil to ensure all engraver data is available
|
||||
(ly:make-stencil
|
||||
`(delay-stencil-evaluation
|
||||
,(delay (begin
|
||||
(when (and (defined? 'chordpro-export-enabled)
|
||||
chordpro-export-enabled
|
||||
(not chordpro-file-written)
|
||||
(> chordpro-current-verse-index 0))
|
||||
(chordpro-write-from-engraver-data chordpro-current-verse-index)
|
||||
(set! chordpro-file-written #t))
|
||||
empty-stencil)))))
|
||||
@@ -2,8 +2,8 @@
|
||||
poetPrefix = "Worte:"
|
||||
composerPrefix = "Weise:"
|
||||
compositionPrefix = "Satz:"
|
||||
adaptionTextPrefix = "Bearbeitung Text:"
|
||||
adaptionMusicPrefix = "Bearbeitung Musik:"
|
||||
adaptionTextPrefix = "Bearbeitung:"
|
||||
adaptionMusicPrefix = "Bearbeitung:"
|
||||
poetAndComposerEqualPrefix = "Worte und Weise:"
|
||||
voicePrefix = "Stimme:"
|
||||
versePrefix = "Strophe:"
|
||||
@@ -12,6 +12,7 @@
|
||||
pronunciationPrefix = "Aussprache:"
|
||||
interludePrefix = "Zwischenspiel:"
|
||||
bridgePrefix = "Bridge:"
|
||||
author-joiner = #(lambda (author-list) (string-join author-list ", "))
|
||||
|
||||
authorFormat =
|
||||
#(lambda (noDetails name trail_name birth_year death_year organization)
|
||||
@@ -31,6 +32,105 @@
|
||||
""
|
||||
)))
|
||||
|
||||
authorContributionFormat =
|
||||
#(lambda* (render-contribution-group render-partial-contribution-group #:key
|
||||
(poetIds '())
|
||||
(translatorIds '())
|
||||
(versePoetData '())
|
||||
(composerIds '())
|
||||
(verseComposerData '())
|
||||
(voiceComposerData '())
|
||||
(compositionIds '())
|
||||
(adaptionTextIds '())
|
||||
(adaptionMusicIds '())
|
||||
(bridgeIds '())
|
||||
(interludeIds '())
|
||||
(year_text #f)
|
||||
(year_translation #f)
|
||||
(year_melody #f)
|
||||
(year_composition #f)
|
||||
(year_adaption_text #f)
|
||||
(year_adaption_music #f)
|
||||
(poetAndComposerEqualPrefix "")
|
||||
(poetPrefix "")
|
||||
(composerPrefix "")
|
||||
(translationAuthorPrefix "")
|
||||
(pronunciationPrefix "")
|
||||
(compositionPrefix "")
|
||||
(adaptionTextPrefix "")
|
||||
(adaptionMusicPrefix "")
|
||||
(bridgePrefix "")
|
||||
(interludePrefix ""))
|
||||
(if (and
|
||||
(equal? poetIds composerIds)
|
||||
(null? translatorIds)
|
||||
(null? versePoetData)
|
||||
(null? verseComposerData)
|
||||
(null? voiceComposerData)
|
||||
(null? compositionIds)
|
||||
(null? adaptionTextIds)
|
||||
(null? adaptionMusicIds)
|
||||
(null? bridgeIds)
|
||||
(null? interludeIds))
|
||||
(list
|
||||
(join-present (list
|
||||
(render-contribution-group poetAndComposerEqualPrefix poetIds)
|
||||
(if (equal? year_text year_melody) year_text (join-present (list year_text year_melody) "/"))
|
||||
) ", ")
|
||||
#f)
|
||||
(list
|
||||
(if (and (null? poetIds) (null? versePoetData) (null? translatorIds)) #f
|
||||
(string-append
|
||||
poetPrefix
|
||||
" "
|
||||
(join-present (list
|
||||
(join-present (list
|
||||
(render-contribution-group "" poetIds)
|
||||
year_text
|
||||
) ", ")
|
||||
(render-partial-contribution-group 'versePrefix versePoetData)
|
||||
(join-present (list
|
||||
(render-contribution-group adaptionTextPrefix adaptionTextIds)
|
||||
year_adaption_text
|
||||
) ", ")
|
||||
(join-present (list
|
||||
(render-contribution-group translationAuthorPrefix translatorIds)
|
||||
year_translation
|
||||
) ", ")
|
||||
) "; ")
|
||||
))
|
||||
(if (and
|
||||
(null? composerIds)
|
||||
(null? compositionIds)
|
||||
(null? adaptionMusicIds)
|
||||
(null? verseComposerData)
|
||||
(null? voiceComposerData)
|
||||
(null? bridgeIds)
|
||||
(null? interludeIds)) #f
|
||||
(string-append
|
||||
composerPrefix
|
||||
" "
|
||||
(join-present (list
|
||||
(join-present (list
|
||||
(render-contribution-group "" composerIds)
|
||||
year_melody
|
||||
) ", ")
|
||||
(render-partial-contribution-group 'versePrefix verseComposerData)
|
||||
(render-partial-contribution-group 'voicePrefix voiceComposerData)
|
||||
(join-present (list
|
||||
(render-contribution-group compositionPrefix compositionIds)
|
||||
year_composition
|
||||
) ", ")
|
||||
(join-present (list
|
||||
(render-contribution-group adaptionMusicPrefix adaptionMusicIds)
|
||||
year_adaption_music
|
||||
) ", ")
|
||||
(render-contribution-group bridgePrefix bridgeIds)
|
||||
(render-contribution-group interludePrefix interludeIds)
|
||||
) "; ")
|
||||
)))))
|
||||
|
||||
|
||||
songinfoMarkup =
|
||||
#(make-on-the-fly-markup
|
||||
(lambda (layout props m)
|
||||
@@ -45,14 +145,16 @@
|
||||
(year_melody (chain-assoc-get 'songinfo:year_melody props #f))
|
||||
(poet-with-year (if (and poet-maybe-with-composer year_text) (string-append poet-maybe-with-composer ", " year_text) poet-maybe-with-composer))
|
||||
(composer-with-year (if (and composer year_melody) (string-append composer ", " year_melody) composer))
|
||||
(concat-markupped-strings (lambda (text)
|
||||
(ly:regex-replace (ly:make-regex "(\\S+)(\\\\\\w+(?:\\s+\\[^\\{\\s]*|\\s*\\{[^\\}]*\\}))(\\S*)") text "\\concat {" 1 "\\line {" 2 "}" 3 "}")))
|
||||
(string-with-paragraphs->markuplist (lambda (prefix text)
|
||||
(if text
|
||||
(apply append
|
||||
(map
|
||||
(lambda (paragraph)
|
||||
(make-wordwrap-internal-markup-list #t
|
||||
#{ \markuplist { $(ly:parser-include-string paragraph) } #}))
|
||||
(ly:regex-split (ly:make-regex "\n[ \t\n]*\n[ \t\n]*") (string-append prefix text))))
|
||||
#{ \markuplist { $(ly:parser-include-string (concat-markupped-strings paragraph)) } #}))
|
||||
(ly:regex-split (ly:make-regex "\r?\n[ \t\r\n]*\n[ \t\r\n]*") (string-append prefix text))))
|
||||
'())))
|
||||
(poet-and-composer-markup-list
|
||||
(string-with-paragraphs->markuplist "" (string-append
|
||||
|
||||
@@ -16,9 +16,10 @@ songTocColumns = 3
|
||||
globalSize = 15
|
||||
lyricSize = 1.6
|
||||
stanzaFormat = "~a."
|
||||
romanStanzaFormat = "~@r."
|
||||
refString = "Ref.:"
|
||||
refStringWithNumbers = "Ref. ~a:"
|
||||
bridgeString = "Bridge:"
|
||||
bridgeStringWithNumbers = "Bridge ~a:"
|
||||
% hübsche Wiederholungszeichen für den Liedtext
|
||||
repStart = "𝄆"
|
||||
repStop = "𝄇"
|
||||
|
||||
@@ -30,6 +30,9 @@
|
||||
(lambda (a b) (< (cadr a) (cadr b))))
|
||||
(list)))
|
||||
|
||||
#(define (join-present items joiner)
|
||||
(string-join (filter (lambda (item) (and (string? item) (not (string-null? (string-trim-both item))))) items) joiner))
|
||||
|
||||
#(define-markup-command (print-songinfo layout props) ()
|
||||
(define (songinfo-from songId key)
|
||||
(let ((song (if (defined? 'SONG_DATA) (assoc-ref SONG_DATA songId) #f)))
|
||||
@@ -74,11 +77,7 @@
|
||||
(define (render-contribution-group contributionPrefix authorIds)
|
||||
(if (null? authorIds)
|
||||
""
|
||||
(string-append contributionPrefix " " (string-join (format-authors authorIds) ", ")))
|
||||
)
|
||||
|
||||
(define (join-present items joiner)
|
||||
(string-join (filter (lambda (item) (and (string? item) (not (string-null? (string-trim-both item))))) items) joiner)
|
||||
(string-append contributionPrefix " " ((ly:output-def-lookup layout 'author-joiner) (format-authors authorIds))))
|
||||
)
|
||||
|
||||
(define (render-partial-contribution-group prefixLookup authorData)
|
||||
@@ -94,93 +93,37 @@
|
||||
|
||||
(define (poet-and-composer-from-authors authors)
|
||||
(if 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))
|
||||
(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))
|
||||
(year_text (chain-assoc-get 'header:year_text props #f))
|
||||
(year_translation (chain-assoc-get 'header:year_translation props #f))
|
||||
(year_melody (chain-assoc-get 'header:year_melody props #f))
|
||||
(year_composition (chain-assoc-get 'header:year_composition props #f))
|
||||
(year_adaption_text (chain-assoc-get 'header:year_adaption_text props #f))
|
||||
(year_adaption_music (chain-assoc-get 'header:year_adaption_music props #f))
|
||||
((ly:output-def-lookup layout 'authorContributionFormat)
|
||||
render-contribution-group
|
||||
render-partial-contribution-group
|
||||
#: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)
|
||||
#:year_text (chain-assoc-get 'header:year_text props #f)
|
||||
#:year_translation (chain-assoc-get 'header:year_translation props #f)
|
||||
#:year_melody (chain-assoc-get 'header:year_melody props #f)
|
||||
#:year_composition (chain-assoc-get 'header:year_composition props #f)
|
||||
#:year_adaption_text (chain-assoc-get 'header:year_adaption_text props #f)
|
||||
#:year_adaption_music (chain-assoc-get 'header:year_adaption_music props #f)
|
||||
#:poetAndComposerEqualPrefix (ly:output-def-lookup layout 'poetAndComposerEqualPrefix)
|
||||
#:poetPrefix (ly:output-def-lookup layout 'poetPrefix)
|
||||
#:composerPrefix (ly:output-def-lookup layout 'composerPrefix)
|
||||
#:translationAuthorPrefix (ly:output-def-lookup layout 'translationAuthorPrefix)
|
||||
#:pronunciationPrefix (ly:output-def-lookup layout 'pronunciationPrefix)
|
||||
#:compositionPrefix (ly:output-def-lookup layout 'compositionPrefix)
|
||||
#:adaptionTextPrefix (ly:output-def-lookup layout 'adaptionTextPrefix)
|
||||
#:adaptionMusicPrefix (ly:output-def-lookup layout 'adaptionMusicPrefix)
|
||||
#:bridgePrefix (ly:output-def-lookup layout 'bridgePrefix)
|
||||
#:interludePrefix (ly:output-def-lookup layout 'interludePrefix)
|
||||
)
|
||||
(if (and
|
||||
(equal? poetIds composerIds)
|
||||
(null? translatorIds)
|
||||
(null? versePoetData)
|
||||
(null? verseComposerData)
|
||||
(null? voiceComposerData)
|
||||
(null? compositionIds)
|
||||
(null? adaptionTextIds)
|
||||
(null? adaptionMusicIds)
|
||||
(null? bridgeIds)
|
||||
(null? interludeIds))
|
||||
(list
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'poetAndComposerEqualPrefix) poetIds)
|
||||
(if (equal? year_text year_melody) year_text (join-present (list year_text year_melody) "/"))
|
||||
) ", ")
|
||||
#f)
|
||||
(list
|
||||
(if (and (null? poetIds) (null? versePoetData) (null? translatorIds)) #f
|
||||
(string-append
|
||||
(ly:output-def-lookup layout 'poetPrefix)
|
||||
" "
|
||||
(join-present (list
|
||||
(join-present (list
|
||||
(render-contribution-group "" poetIds)
|
||||
year_text
|
||||
) ", ")
|
||||
(render-partial-contribution-group 'versePrefix versePoetData)
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'translationAuthorPrefix) translatorIds)
|
||||
year_translation
|
||||
) ", ")
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'adaptionTextPrefix) adaptionTextIds)
|
||||
year_adaption_text
|
||||
) ", ")
|
||||
) "; ")
|
||||
))
|
||||
(if (and
|
||||
(null? composerIds)
|
||||
(null? compositionIds)
|
||||
(null? adaptionMusicIds)
|
||||
(null? verseComposerData)
|
||||
(null? voiceComposerData)
|
||||
(null? bridgeIds)
|
||||
(null? interludeIds)) #f
|
||||
(string-append
|
||||
(ly:output-def-lookup layout 'composerPrefix)
|
||||
" "
|
||||
(join-present (list
|
||||
(join-present (list
|
||||
(render-contribution-group "" composerIds)
|
||||
year_melody
|
||||
) ", ")
|
||||
(render-partial-contribution-group 'versePrefix verseComposerData)
|
||||
(render-partial-contribution-group 'voicePrefix voiceComposerData)
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'compositionPrefix) compositionIds)
|
||||
year_composition
|
||||
) ", ")
|
||||
(join-present (list
|
||||
(render-contribution-group (ly:output-def-lookup layout 'adaptionMusicPrefix) adaptionMusicIds)
|
||||
year_adaption_music
|
||||
) ", ")
|
||||
(render-contribution-group (ly:output-def-lookup layout 'bridgePrefix) bridgeIds)
|
||||
(render-contribution-group (ly:output-def-lookup layout 'interludePrefix) interludeIds)
|
||||
) "; ")
|
||||
)))))
|
||||
(list #f #f)
|
||||
)
|
||||
)
|
||||
@@ -242,13 +185,23 @@
|
||||
`(line-width . ,(* (chain-assoc-get 'header:songinfo-size-factor props songInfoLineWidthFraction) (ly:output-def-lookup layout 'line-width)))
|
||||
arg)))
|
||||
|
||||
#(define pdf-encode (@@ (lily framework-ps) pdf-encode))
|
||||
% PDF tags
|
||||
#(define-markup-command (page-number-to-pdf-label layout props) ()
|
||||
(ly:make-stencil
|
||||
(list 'embedded-ps
|
||||
(ly:format
|
||||
"[ /Label (~a) /PAGELABEL pdfmark\n" (pdf-encode (chain-assoc-get 'page:page-number-string props "?"))))
|
||||
empty-interval empty-interval
|
||||
))
|
||||
|
||||
\paper {
|
||||
print-first-page-number = ##t
|
||||
first-page-number = #0
|
||||
|
||||
oddFooterMarkup = \markup {
|
||||
\fill-line {
|
||||
\line { \null }
|
||||
\line { \page-number-to-pdf-label \null }
|
||||
\line { \if \on-last-page-of-part \general-align #Y #DOWN \fractional-line-width \print-songinfo }
|
||||
\line { \if \should-print-page-number \print-pagenumber }
|
||||
}
|
||||
@@ -257,7 +210,7 @@
|
||||
\fill-line {
|
||||
\line { \if \should-print-page-number \print-pagenumber }
|
||||
\line { \if \on-last-page-of-part \general-align #Y #DOWN \fractional-line-width \print-songinfo }
|
||||
\line { \null }
|
||||
\line { \page-number-to-pdf-label \null }
|
||||
}
|
||||
}
|
||||
}
|
||||
13
private_includes/base/markup_tag_groups_hack.ily
Normal file
13
private_includes/base/markup_tag_groups_hack.ily
Normal file
@@ -0,0 +1,13 @@
|
||||
% We have to record the tag groups for markup, so we use the right tag groups during markup interpretiton.
|
||||
recordedTagGroups = #'()
|
||||
|
||||
tagGroup =
|
||||
#(define-void-function (tags) (symbol-list?)
|
||||
(let ((err (define-tag-group tags)))
|
||||
(if err (ly:parser-error err (*location*))
|
||||
(set! recordedTagGroups (cons tags recordedTagGroups)))))
|
||||
|
||||
#(define-markup-command (handle-tag-groups layout props recorded-groups m) (list? markup?)
|
||||
(resetTagGroups)
|
||||
(every (lambda (group) (define-tag-group group)) recorded-groups)
|
||||
(interpret-markup layout props m))
|
||||
86
private_includes/base/merge_rests_engraver_override.ily
Normal file
86
private_includes/base/merge_rests_engraver_override.ily
Normal file
@@ -0,0 +1,86 @@
|
||||
Better_Merge_rests_engraver =
|
||||
#(lambda (context)
|
||||
(define (has-one-or-less? lst) (or (null? lst) (null? (cdr lst))))
|
||||
(define (has-at-least-two? lst) (not (has-one-or-less? lst)))
|
||||
(define (all-equal? lst pred)
|
||||
(or (has-one-or-less? lst)
|
||||
(and (pred (car lst) (cadr lst)) (all-equal? (cdr lst) pred))))
|
||||
(define (measure-count-eqv? a b)
|
||||
(eqv?
|
||||
(ly:grob-property a 'measure-count)
|
||||
(ly:grob-property b 'measure-count)))
|
||||
|
||||
(define (rests-all-unpitched? rests)
|
||||
"Returns true when all rests do not override the staff-position grob
|
||||
property. When a rest has a position set we do not want to merge rests at
|
||||
that position."
|
||||
(every (lambda (rest) (null? (ly:grob-property rest 'staff-position))) rests))
|
||||
|
||||
(define (less-by-layer a b)
|
||||
(<
|
||||
(ly:grob-property b 'layer 0)
|
||||
(ly:grob-property a 'layer 0)))
|
||||
|
||||
(define (merge-mmrests mmrests)
|
||||
"Move all multimeasure rests to the single voice location."
|
||||
(if (all-equal? mmrests measure-count-eqv?)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (rest) (ly:grob-set-property! rest 'direction CENTER))
|
||||
mmrests)
|
||||
(for-each
|
||||
(lambda (rest) (ly:grob-set-property! rest 'transparent #t))
|
||||
(cdr (sort mmrests less-by-layer))))))
|
||||
|
||||
(define (merge-rests rests)
|
||||
(for-each
|
||||
(lambda (rest) (ly:grob-set-property! rest 'staff-position 0))
|
||||
rests)
|
||||
(for-each
|
||||
(lambda (rest) (ly:grob-set-property! rest 'transparent #t))
|
||||
(cdr (sort rests less-by-layer))))
|
||||
|
||||
(let ((mmrests '())
|
||||
(rests '())
|
||||
(dots '()))
|
||||
(make-engraver
|
||||
((start-translation-timestep translator)
|
||||
(set! rests '())
|
||||
(set! mmrests '())
|
||||
(set! dots '()))
|
||||
(acknowledgers
|
||||
((dot-column-interface engraver grob source-engraver)
|
||||
(if (not (ly:context-property context 'suspendRestMerging #f))
|
||||
(set!
|
||||
dots
|
||||
(append (ly:grob-array->list (ly:grob-object grob 'dots))
|
||||
dots))))
|
||||
((rest-interface engraver grob source-engraver)
|
||||
(cond
|
||||
((ly:context-property context 'suspendRestMerging #f)
|
||||
#f)
|
||||
((grob::has-interface grob 'multi-measure-rest-interface)
|
||||
(set! mmrests (cons grob mmrests)))
|
||||
(else
|
||||
(set! rests (cons grob rests))))))
|
||||
((stop-translation-timestep translator)
|
||||
(let (;; get a list of the rests 'duration-lengths, 'duration-log does
|
||||
;; not take dots into account
|
||||
(durs
|
||||
(map
|
||||
(lambda (g)
|
||||
(ly:duration->moment
|
||||
(ly:prob-property
|
||||
(ly:grob-property g 'cause)
|
||||
'duration)))
|
||||
rests)))
|
||||
(if (and
|
||||
(has-at-least-two? rests)
|
||||
(all-equal? durs equal?)
|
||||
(rests-all-unpitched? rests))
|
||||
(begin
|
||||
(merge-rests rests)
|
||||
;; ly:grob-suicide! works nicely for dots, as opposed to rests.
|
||||
(if (pair? dots) (for-each ly:grob-suicide! (cdr dots)))))
|
||||
(if (has-at-least-two? mmrests)
|
||||
(merge-mmrests mmrests)))))))
|
||||
@@ -1,482 +0,0 @@
|
||||
;;; (json parser) --- Guile JSON implementation.
|
||||
|
||||
;; Copyright (C) 2013-2020 Aleix Conchillo Flaque <aconchillo@gmail.com>
|
||||
;;
|
||||
;; This file is part of guile-json.
|
||||
;;
|
||||
;; guile-json is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
;;
|
||||
;; guile-json is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with guile-json. If not, see https://www.gnu.org/licenses/.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; JSON module for Guile
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (json parser)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 streams)
|
||||
#:use-module (rnrs io ports)
|
||||
#:export (json->scm
|
||||
json-string->scm
|
||||
json-seq->scm
|
||||
json-seq-string->scm))
|
||||
|
||||
;;
|
||||
;; Miscellaneuos helpers
|
||||
;;
|
||||
|
||||
(define (json-exception port)
|
||||
(throw 'json-invalid port))
|
||||
|
||||
(define (digit? c)
|
||||
(case c
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (whitespace? c)
|
||||
(case c
|
||||
((#\sp #\ht #\lf #\cr) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (control-char? ch)
|
||||
(<= (char->integer ch) #x1F))
|
||||
|
||||
(define (skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((whitespace? ch)
|
||||
(read-char port)
|
||||
(skip-whitespaces port))
|
||||
(else *unspecified*))))
|
||||
|
||||
(define (expect-string port expected return)
|
||||
(let loop ((n 0))
|
||||
(cond
|
||||
;; All characters match.
|
||||
((= n (string-length expected)) return)
|
||||
;; Go to next characters.
|
||||
((eqv? (read-char port) (string-ref expected n))
|
||||
(loop (+ n 1)))
|
||||
;; Anything else is an error.
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (expect-delimiter port delimiter)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((not (eqv? ch delimiter)) (json-exception port))
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port)))))
|
||||
|
||||
(define (skip-record-separators port)
|
||||
(when (eqv? #\rs (peek-char port))
|
||||
(read-char port)
|
||||
(skip-record-separators port)))
|
||||
|
||||
;;
|
||||
;; Number parsing helpers
|
||||
;;
|
||||
|
||||
(define (expect-digit port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((not (digit? ch)) (json-exception port))
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port)))))
|
||||
|
||||
;; Read + or -, and return 1 or -1 respectively. If something different is
|
||||
;; found, return 1.
|
||||
(define (read-sign port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((eqv? ch #\+)
|
||||
(read-char port)
|
||||
1)
|
||||
((eqv? ch #\-)
|
||||
(read-char port)
|
||||
-1)
|
||||
(else 1))))
|
||||
|
||||
(define (read-digit-value port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\0) 0)
|
||||
((eqv? ch #\1) 1)
|
||||
((eqv? ch #\2) 2)
|
||||
((eqv? ch #\3) 3)
|
||||
((eqv? ch #\4) 4)
|
||||
((eqv? ch #\5) 5)
|
||||
((eqv? ch #\6) 6)
|
||||
((eqv? ch #\7) 7)
|
||||
((eqv? ch #\8) 8)
|
||||
((eqv? ch #\9) 9)
|
||||
(else (json-exception port)))))
|
||||
|
||||
;; Read digits [0..9].
|
||||
(define (read-digits port)
|
||||
(expect-digit port)
|
||||
(let loop ((ch (peek-char port)) (number 0))
|
||||
(cond
|
||||
((digit? ch)
|
||||
(let ((value (read-digit-value port)))
|
||||
(loop (peek-char port) (+ (* number 10) value))))
|
||||
(else number))))
|
||||
|
||||
(define (read-digits-fraction port)
|
||||
(expect-digit port)
|
||||
(let loop ((ch (peek-char port)) (number 0) (length 0))
|
||||
(cond
|
||||
((digit? ch)
|
||||
(let ((value (read-digit-value port)))
|
||||
(loop (peek-char port) (+ (* number 10) value) (+ length 1))))
|
||||
(else
|
||||
(/ number (expt 10 length))))))
|
||||
|
||||
(define (read-exponent port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((or (eqv? ch #\e) (eqv? ch #\E))
|
||||
(read-char port)
|
||||
(let ((sign (read-sign port))
|
||||
(digits (read-digits port)))
|
||||
(if (<= digits 1000) ;; Some maximum exponent.
|
||||
(expt 10 (* sign digits))
|
||||
(json-exception port))))
|
||||
(else 1))))
|
||||
|
||||
(define (read-fraction port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((eqv? ch #\.)
|
||||
(read-char port)
|
||||
(read-digits-fraction port))
|
||||
(else 0))))
|
||||
|
||||
(define (read-positive-number port)
|
||||
(let* ((number
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Numbers that start with 0 must be a fraction.
|
||||
((eqv? ch #\0)
|
||||
(read-char port)
|
||||
0)
|
||||
;; Otherwise read more digits.
|
||||
(else (read-digits port)))))
|
||||
(fraction (read-fraction port))
|
||||
(exponent (read-exponent port))
|
||||
(result (* (+ number fraction) exponent)))
|
||||
(if (and (zero? fraction) (>= exponent 1))
|
||||
result
|
||||
(exact->inexact result))))
|
||||
|
||||
(define (json-read-number port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Negative numbers.
|
||||
((eqv? ch #\-)
|
||||
(read-char port)
|
||||
(expect-digit port)
|
||||
(* -1 (read-positive-number port)))
|
||||
;; Positive numbers.
|
||||
((digit? ch)
|
||||
(read-positive-number port))
|
||||
;; Anything else is an error.
|
||||
(else (json-exception port)))))
|
||||
|
||||
;;
|
||||
;; Object parsing helpers
|
||||
;;
|
||||
|
||||
(define (read-pair port null ordered)
|
||||
;; Read key.
|
||||
(let ((key (json-read-string port)))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Skip colon and read value.
|
||||
((eqv? ch #\:)
|
||||
(read-char port)
|
||||
(cons key (json-read port null ordered)))
|
||||
;; Anything other than colon is an error.
|
||||
(else (json-exception port))))))
|
||||
|
||||
(define (json-read-object port null ordered)
|
||||
(expect-delimiter port #\{)
|
||||
(let loop ((pairs '()) (added #t))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; End of object.
|
||||
((eqv? ch #\})
|
||||
(read-char port)
|
||||
(cond
|
||||
(added (if ordered (reverse! pairs) pairs))
|
||||
(else (json-exception port))))
|
||||
;; Read one pair and continue.
|
||||
((eqv? ch #\")
|
||||
(let ((pair (read-pair port null ordered)))
|
||||
(loop (cons pair pairs) #t)))
|
||||
;; Skip comma and read more pairs.
|
||||
((eqv? ch #\,)
|
||||
(read-char port)
|
||||
(cond
|
||||
(added (loop pairs #f))
|
||||
(else (json-exception port))))
|
||||
;; Invalid object.
|
||||
(else (json-exception port))))))
|
||||
|
||||
;;
|
||||
;; Array parsing helpers
|
||||
;;
|
||||
|
||||
(define (json-read-array port null ordered)
|
||||
(expect-delimiter port #\[)
|
||||
(skip-whitespaces port)
|
||||
(cond
|
||||
;; Special case when array is empty.
|
||||
((eqv? (peek-char port) #\])
|
||||
(read-char port)
|
||||
#())
|
||||
(else
|
||||
;; Read first element in array.
|
||||
(let loop ((values (list (json-read port null ordered))))
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Handle comma (if there's a comma there should be another element).
|
||||
((eqv? ch #\,)
|
||||
(read-char port)
|
||||
(loop (cons (json-read port null ordered) values)))
|
||||
;; End of array.
|
||||
((eqv? ch #\])
|
||||
(read-char port)
|
||||
(list->vector (reverse! values)))
|
||||
;; Anything else other than comma and end of array is wrong.
|
||||
(else (json-exception port))))))))
|
||||
|
||||
;;
|
||||
;; String parsing helpers
|
||||
;;
|
||||
|
||||
(define (read-hex-digit->integer port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\0) 0)
|
||||
((eqv? ch #\1) 1)
|
||||
((eqv? ch #\2) 2)
|
||||
((eqv? ch #\3) 3)
|
||||
((eqv? ch #\4) 4)
|
||||
((eqv? ch #\5) 5)
|
||||
((eqv? ch #\6) 6)
|
||||
((eqv? ch #\7) 7)
|
||||
((eqv? ch #\8) 8)
|
||||
((eqv? ch #\9) 9)
|
||||
((or (eqv? ch #\A) (eqv? ch #\a)) 10)
|
||||
((or (eqv? ch #\B) (eqv? ch #\b)) 11)
|
||||
((or (eqv? ch #\C) (eqv? ch #\c)) 12)
|
||||
((or (eqv? ch #\D) (eqv? ch #\d)) 13)
|
||||
((or (eqv? ch #\E) (eqv? ch #\e)) 14)
|
||||
((or (eqv? ch #\F) (eqv? ch #\f)) 15)
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (read-unicode-value port)
|
||||
(+ (* 4096 (read-hex-digit->integer port))
|
||||
(* 256 (read-hex-digit->integer port))
|
||||
(* 16 (read-hex-digit->integer port))
|
||||
(read-hex-digit->integer port)))
|
||||
|
||||
;; Unicode codepoint with surrogates is:
|
||||
;; 10000 + (high - D800) + (low - DC00)
|
||||
;; which is equivalent to:
|
||||
;; (high << 10) + low - 35FDC00
|
||||
;; see
|
||||
;; https://github.com/aconchillo/guile-json/issues/58#issuecomment-662744070
|
||||
(define (json-surrogate-pair->unicode high low)
|
||||
(+ (* high #x400) low #x-35FDC00))
|
||||
|
||||
(define (read-unicode-char port)
|
||||
(let ((codepoint (read-unicode-value port)))
|
||||
(cond
|
||||
;; Surrogate pairs. `codepoint` already contains the higher surrogate
|
||||
;; (between D800 and DC00) . At this point we are expecting another
|
||||
;; \uXXXX that holds the lower surrogate (between DC00 and DFFF).
|
||||
((and (>= codepoint #xD800) (< codepoint #xDC00))
|
||||
(expect-string port "\\u" #f)
|
||||
(let ((low-surrogate (read-unicode-value port)))
|
||||
(if (and (>= low-surrogate #xDC00) (< low-surrogate #xE000))
|
||||
(integer->char (json-surrogate-pair->unicode codepoint low-surrogate))
|
||||
(json-exception port))))
|
||||
;; Reserved for surrogates (we just need to check starting from the low
|
||||
;; surrogates).
|
||||
((and (>= codepoint #xDC00) (< codepoint #xE000))
|
||||
(json-exception port))
|
||||
(else (integer->char codepoint)))))
|
||||
|
||||
(define (read-control-char port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eqv? ch #\") #\")
|
||||
((eqv? ch #\\) #\\)
|
||||
((eqv? ch #\/) #\/)
|
||||
((eqv? ch #\b) #\bs)
|
||||
((eqv? ch #\f) #\ff)
|
||||
((eqv? ch #\n) #\lf)
|
||||
((eqv? ch #\r) #\cr)
|
||||
((eqv? ch #\t) #\ht)
|
||||
((eqv? ch #\u) (read-unicode-char port))
|
||||
(else (json-exception port)))))
|
||||
|
||||
(define (json-read-string port)
|
||||
(expect-delimiter port #\")
|
||||
(let loop ((chars '()) (ch (read-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Unescaped control characters are not allowed.
|
||||
((control-char? ch) (json-exception port))
|
||||
;; End of string.
|
||||
((eqv? ch #\") (reverse-list->string chars))
|
||||
;; Escaped characters.
|
||||
((eqv? ch #\\)
|
||||
(loop (cons (read-control-char port) chars) (read-char port)))
|
||||
;; All other characters.
|
||||
(else
|
||||
(loop (cons ch chars) (read-char port))))))
|
||||
|
||||
;;
|
||||
;; Booleans and null parsing helpers
|
||||
;;
|
||||
|
||||
(define (json-read-true port)
|
||||
(expect-string port "true" #t))
|
||||
|
||||
(define (json-read-false port)
|
||||
(expect-string port "false" #f))
|
||||
|
||||
(define (json-read-null port null)
|
||||
(expect-string port "null" null))
|
||||
|
||||
;;
|
||||
;; Main parser functions
|
||||
;;
|
||||
|
||||
(define (json-read port null ordered)
|
||||
(skip-whitespaces port)
|
||||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
;; Unexpected EOF.
|
||||
((eof-object? ch) (json-exception port))
|
||||
;; Read JSON values.
|
||||
((eqv? ch #\t) (json-read-true port))
|
||||
((eqv? ch #\f) (json-read-false port))
|
||||
((eqv? ch #\n) (json-read-null port null))
|
||||
((eqv? ch #\{) (json-read-object port null ordered))
|
||||
((eqv? ch #\[) (json-read-array port null ordered))
|
||||
((eqv? ch #\") (json-read-string port))
|
||||
;; Anything else should be a number.
|
||||
(else (json-read-number port)))))
|
||||
|
||||
;;
|
||||
;; Public procedures
|
||||
;;
|
||||
|
||||
(define* (json->scm #:optional (port (current-input-port))
|
||||
#:key (null 'null) (ordered #f) (concatenated #f))
|
||||
"Parse a JSON document into native. Takes one optional argument,
|
||||
@var{port}, which defaults to the current input port from where the JSON
|
||||
document is read. It also takes a few of keyword arguments: @{null}: value for
|
||||
JSON's null, it defaults to the 'null symbol, @{ordered} to indicate whether
|
||||
JSON objects order should be preserved or not (the default) and @{concatenated}
|
||||
which can be used to tell the parser that more JSON documents might come after a
|
||||
properly parsed document."
|
||||
(let loop ((value (json-read port null ordered)))
|
||||
;; Skip any trailing whitespaces.
|
||||
(skip-whitespaces port)
|
||||
(cond
|
||||
;; If we reach the end the parsing succeeded.
|
||||
((eof-object? (peek-char port)) value)
|
||||
;; If there's anything else other than the end, check if user wants to keep
|
||||
;; parsing concatenated valid JSON documents, otherwise parser fails.
|
||||
(else
|
||||
(cond (concatenated value)
|
||||
(else (json-exception port)))))))
|
||||
|
||||
(define* (json-string->scm str #:key (null 'null) (ordered #f))
|
||||
"Parse a JSON document into native. Takes a string argument,
|
||||
@var{str}, that contains the JSON document. It also takes a couple of keyword
|
||||
argument: @{null}: value for JSON's null, it defaults to the 'null symbol and
|
||||
@{ordered} to indicate whether JSON objects order should be preserved or
|
||||
not (the default)."
|
||||
(call-with-input-string str (lambda (p) (json->scm p #:null null #:ordered ordered))))
|
||||
|
||||
(define* (json-seq->scm #:optional (port (current-input-port))
|
||||
#:key (null 'null) (ordered #f)
|
||||
(handle-truncate 'skip) (truncated-object 'truncated))
|
||||
"Lazy parse a JSON text sequence from the port @var{port}.
|
||||
This procedure returns a stream of parsed documents. The optional argument
|
||||
@var{port} defines the port to read from and defaults to the current input
|
||||
port. It also takes a few keyword arguments: @{null}: value for JSON's null
|
||||
(defaults to the 'null symbol), @{ordered} to indicate whether JSON objects
|
||||
order should be preserved or not (the default), @{handle-truncate}: defines how
|
||||
to handle data loss, @{truncated-object}: used to replace unparsable
|
||||
objects. Allowed values for @{handle-truncate} argument are 'throw (throw an
|
||||
exception), 'stop (stop parsing and end the stream), 'skip (default, skip
|
||||
corrupted fragment and return the next entry), 'replace (skip corrupted fragment
|
||||
and return @{truncated-object} instead)."
|
||||
(letrec ((handle-truncation
|
||||
(case handle-truncate
|
||||
((throw) json-exception)
|
||||
((stop) (const (eof-object)))
|
||||
((skip)
|
||||
(lambda (port)
|
||||
(read-delimited "\x1e" port 'peek)
|
||||
(read-entry port)))
|
||||
((replace)
|
||||
(lambda (port)
|
||||
(read-delimited "\x1e" port 'peek)
|
||||
truncated-object))))
|
||||
(read-entry
|
||||
(lambda (port)
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eof-object? ch) ch)
|
||||
((not (eqv? ch #\rs))
|
||||
(handle-truncation port))
|
||||
(else
|
||||
(skip-record-separators port)
|
||||
(catch 'json-invalid
|
||||
(lambda ()
|
||||
(let ((next (json-read port null ordered)))
|
||||
(if (eqv? #\lf (peek-char port))
|
||||
(begin
|
||||
(read-char port)
|
||||
next)
|
||||
(handle-truncation port))))
|
||||
(lambda (_ port)
|
||||
(handle-truncation port)))))))))
|
||||
(port->stream port read-entry)))
|
||||
|
||||
(define* (json-seq-string->scm str #:key (null 'null) (ordered #f)
|
||||
(handle-truncate 'skip) (truncated-object 'truncated))
|
||||
"Lazy parse a JSON text sequence from the string @var{str}.
|
||||
This procedure returns a stream of parsed documents and also takes the same
|
||||
keyword arguments as @code{json-seq->scm}."
|
||||
(call-with-input-string str
|
||||
(lambda (p)
|
||||
(json-seq->scm p #:null null #:ordered ordered
|
||||
#:handle-truncate handle-truncate
|
||||
#:truncated-object truncated-object))))
|
||||
|
||||
;;; (json parser) ends here
|
||||
@@ -1,25 +1,154 @@
|
||||
(if (not windows?) (use-modules (ice-9 popen)))
|
||||
(use-modules (ice-9 textual-ports) (json parser))
|
||||
(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 pretty-print) (srfi srfi-1))
|
||||
|
||||
; We use Python to convert the data yamls like the authors.yml to json, that we can parse in scheme.
|
||||
; Windows does not like Pipes, so we use a tmpfile instead.
|
||||
; Be sure you have PyYAML installed. On Windows that could be done for example like "py -m pip install PyYAML"
|
||||
;; Hauptparsingfunktion
|
||||
(define (yml-file->scm filename)
|
||||
(if windows?
|
||||
(let* ((port (make-tmpfile #f))
|
||||
(tmpfilepath (port-filename port))
|
||||
(ignore (close-port port))
|
||||
(python_code (string-append "import sys, yaml, json; f = open(r'" tmpfilepath "', 'w'); f.write(json.dumps(yaml.safe_load(open(r'" filename "')))); f.close()"))
|
||||
(status (system (string-append (search-executable '("python3" "python" "py")) " -X utf8 -c \"" python_code "\"")))
|
||||
(readport (open-file tmpfilepath "r" #:encoding "UTF-8"))
|
||||
(json (get-string-all readport)))
|
||||
(close-port readport)
|
||||
(delete-file tmpfilepath)
|
||||
(json-string->scm (if (status:exit-val status) json "{}")))
|
||||
(let* ((python_code (string-append "import sys, yaml, json; print(json.dumps(yaml.safe_load(open(r'" filename "'))))"))
|
||||
(pipe (open-pipe (string-append "PYTHONHOME='' " (search-executable '("python3" "python" "py")) " -X utf8 -c \"" python_code "\"") OPEN_READ))
|
||||
(json (get-string-all pipe)))
|
||||
(close-pipe pipe)
|
||||
(json-string->scm json))))
|
||||
|
||||
;; Utility: Zeile einlesen
|
||||
(define (read-lines filename)
|
||||
(call-with-input-file filename
|
||||
(lambda (port)
|
||||
(let loop ((lines '()))
|
||||
(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))))))))))
|
||||
|
||||
;; 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
|
||||
|
||||
;; Kommentar entfernen
|
||||
(define (strip-comment line)
|
||||
(let ((m (string-match "#.*" line)))
|
||||
(if m
|
||||
(string-trim-right (string-take line (match:start m)))
|
||||
line)))
|
||||
|
||||
;; Hilfsfunktion: Whitespace entfernen
|
||||
(define (clean-line line)
|
||||
(string-trim (strip-comment line)))
|
||||
|
||||
;; Ist Zeile leer (nach Entfernen von Kommentar & Whitespace)?
|
||||
(define (blank-or-comment? line)
|
||||
(string-null? (clean-line line)))
|
||||
|
||||
;; Skalare Werte interpretieren
|
||||
(define (parse-scalar str)
|
||||
(define (strip-quotes s)
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
;; 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))))))
|
||||
|
||||
;; 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)))))
|
||||
|
||||
;; 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))))))
|
||||
|
||||
;; 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
|
||||
((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)))
|
||||
|
||||
(define (parse-yml-file filename) (resolve-inherits (yml-file->scm filename)))
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
swing = \mark \markup {
|
||||
swing = \textMark \markup {
|
||||
\line \general-align #Y #DOWN {
|
||||
\score {
|
||||
\new Staff \with {
|
||||
@@ -47,7 +47,7 @@ swing = \mark \markup {
|
||||
}
|
||||
}
|
||||
|
||||
swingOff = \mark \markup {
|
||||
swingOff = \textMark \markup {
|
||||
\line \general-align #Y #DOWN {
|
||||
\score {
|
||||
\new Staff \with {
|
||||
@@ -99,7 +99,7 @@ swingOff = \mark \markup {
|
||||
\include "swing.ly"
|
||||
|
||||
swingMusic =
|
||||
#(define-music-function (parser location music) (ly:music?)
|
||||
#(define-music-function (music) (ly:music?)
|
||||
(define (partial-duration-length m)
|
||||
(let ((name (ly:music-property m 'name))
|
||||
(es (ly:music-property m 'elements))
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
#(define-markup-command (bookTitleMarkupCustom layout props)()
|
||||
(interpret-markup layout
|
||||
(prepend-alist-chain 'songfilename (chain-assoc-get 'header:songfilename props "") props)
|
||||
(interpret-markup layout props
|
||||
(make-column-markup
|
||||
(list
|
||||
(make-vspace-markup (chain-assoc-get 'header:titletopspace props 0))
|
||||
@@ -28,31 +27,34 @@
|
||||
#(define pdf-encode (@@ (lily framework-ps) pdf-encode))
|
||||
% PDF tags
|
||||
#(define-markup-command (title-to-pdf-toc layout props title) (string?)
|
||||
(if (string-null? title)
|
||||
empty-stencil
|
||||
(ly:make-stencil
|
||||
(list 'embedded-ps
|
||||
(ly:format
|
||||
"[/Action /GoTo /View [/XYZ -4 currentpagedevice /PageSize get 1 get 4 add null] /Title (~a) /OUT pdfmark" (pdf-encode title)))
|
||||
empty-interval empty-interval
|
||||
;'(0 . 0) '(0 . 0)
|
||||
))
|
||||
)))
|
||||
|
||||
#(define-markup-command (title-with-category-images layout props right)(boolean?)
|
||||
(interpret-markup layout props
|
||||
#(define-markup-command (build-full-title layout props right)(boolean?)
|
||||
(interpret-markup layout (prepend-alist-chain 'songfilename (chain-assoc-get 'header:songfilename props "") props)
|
||||
(let* ((title (chain-assoc-get 'header:title props ""))
|
||||
(starttext (chain-assoc-get 'header:starttext props #f))
|
||||
(pdfbookmark (if starttext (string-append starttext " | " title) title)))
|
||||
(pdfbookmark (if starttext (string-append starttext " | " title) title))
|
||||
(title-markup (ly:output-def-lookup layout (if right 'oddTitleLineMarkup 'evenTitleLineMarkup))))
|
||||
(if title
|
||||
(if right
|
||||
#{\markup { \title-to-pdf-toc #pdfbookmark \fill-line \general-align #Y #UP { \null \bookTitleMarkupCustom \category-images } } #}
|
||||
#{\markup { \title-to-pdf-toc #pdfbookmark \fill-line \general-align #Y #UP { \category-images \bookTitleMarkupCustom \null } } #})
|
||||
#{ \markup { " " } #})
|
||||
(markup #:title-to-pdf-toc pdfbookmark title-markup)
|
||||
make-null-markup)
|
||||
)))
|
||||
|
||||
\paper {
|
||||
bookTitleMarkup = \markup \null
|
||||
scoreTitleMarkup = \markup \null
|
||||
oddHeaderMarkup = \markup { \if \on-first-page-of-part \title-with-category-images ##t }
|
||||
evenHeaderMarkup = \markup { \if \on-first-page-of-part \title-with-category-images ##f }
|
||||
oddHeaderMarkup = \markup { \if \on-first-page-of-part \build-full-title ##t }
|
||||
evenHeaderMarkup = \markup { \if \on-first-page-of-part \build-full-title ##f }
|
||||
oddTitleLineMarkup = \markup { \fill-line \general-align #Y #UP { \null \bookTitleMarkupCustom \category-images } }
|
||||
evenTitleLineMarkup = \markup { \fill-line \general-align #Y #UP { \category-images \bookTitleMarkupCustom \null } }
|
||||
defaultTitleMarkup = \markup {
|
||||
\override #'(baseline-skip . 3.5)
|
||||
\center-column {
|
||||
|
||||
@@ -60,19 +60,20 @@
|
||||
|
||||
% Text über Text mittig darstellen
|
||||
#(define-markup-command (textup layout props text uptext) (markup? markup?)
|
||||
#:properties ((verselayout generalLayout)
|
||||
(verse-text-chord-distance songTextChordDistance))
|
||||
"Markup über Text mittig darstellen."
|
||||
(let ((verselayout (chain-assoc-get 'verselayout props generalLayout)))
|
||||
(interpret-markup layout props
|
||||
#{\markup {
|
||||
\size-box-to-box-style-dependent ##t ##f
|
||||
\general-align #X #LEFT \override #`(direction . ,UP) \override #'(baseline-skip . 1.0) \dir-column \chord-alignment-style-dependent {
|
||||
\pad-to-box #'(0 . 0) #'(0 . 2.0) { #text }
|
||||
\size-box-to-box ##f ##t #uptext \score { \chords { g4:m a } \layout { \verselayout } }
|
||||
\general-align #X #LEFT \override #`(direction . ,UP) \override #'(baseline-skip . 1) \dir-column \chord-alignment-style-dependent {
|
||||
\pad-to-box #'(0 . 0) #`(0 . ,(- verse-text-chord-distance 0.8)) { #text }
|
||||
\size-box-to-box ##f ##t #uptext \score { \chords { g4:m a } \layout { $verselayout #(customized-layout verselayout) } }
|
||||
}
|
||||
#text
|
||||
}
|
||||
#}
|
||||
)))
|
||||
))
|
||||
|
||||
#(define-markup-command (anchor-x-between layout props arga argb)
|
||||
(markup? markup?)
|
||||
@@ -82,16 +83,15 @@
|
||||
(ly:stencil-aligned-to m X (- (/ (* la 2) l) 1))
|
||||
))
|
||||
|
||||
#(define-markup-command (stanza-raw layout props arg)
|
||||
(string-or-music?)
|
||||
(let ((verselayout (chain-assoc-get 'verselayout props generalLayout)))
|
||||
#(define-markup-command (stanza-raw layout props arg) (string-or-music?)
|
||||
#:properties ((verselayout generalLayout))
|
||||
(interpret-markup layout props
|
||||
(if (and (string? arg) (string-null? arg))
|
||||
" "
|
||||
#{\markup
|
||||
\score { \new Lyrics { \lyricmode { #(if (ly:music? arg) arg #{ \set stanza = #arg #}) "" } } \layout { \verselayout } }
|
||||
\score { \new Lyrics { \lyricmode { #(if (ly:music? arg) arg #{ \set stanza = #arg #}) "" } } \layout { $verselayout #(customized-layout verselayout) } }
|
||||
#}
|
||||
))))
|
||||
)))
|
||||
|
||||
#(define-markup-command (stanza layout props arg)
|
||||
(string-or-music?)
|
||||
@@ -141,7 +141,7 @@
|
||||
(make-wrap-newline-markup
|
||||
(ly:regex-replace (ly:make-regex "\\(( *)([^,()]*)( *),([^)]*)\\)")
|
||||
(ly:regex-replace (ly:make-regex "(([^ \n]*\\([^()]*,[^()]+\\)[^ \n(]*)+)") (handle-custom-newlines custom-verse-breaks verse) " \\concat { " 1 " } ")
|
||||
"\\textup \\line { \"" 1 "\" " 2 " \"" 3 "\" } \\score { " transp " \\chords { s4 " 4 " } \\layout { \\verselayout } }")
|
||||
"\\textup \\line { \"" 1 "\" " 2 " \"" 3 "\" } \\score { " transp " \\chords { s4 " 4 " } \\layout { $verselayout #(customized-layout verselayout) } }")
|
||||
)
|
||||
))))
|
||||
|
||||
@@ -203,23 +203,9 @@
|
||||
|
||||
#(define-markup-command (pad-left layout props amount arg)
|
||||
(number? markup?)
|
||||
(let* ((m (interpret-markup layout props arg))
|
||||
(x (ly:stencil-extent m X))
|
||||
(y (ly:stencil-extent m Y)))
|
||||
(ly:stencil-translate
|
||||
(ly:make-stencil (ly:stencil-expr m)
|
||||
(cons (- (car x) amount) (cdr x))
|
||||
y)
|
||||
`(,amount . 0))))
|
||||
|
||||
#(define-markup-command (pad-right layout props amount arg)
|
||||
(number? markup?)
|
||||
(let* ((m (interpret-markup layout props arg))
|
||||
(x (ly:stencil-extent m X))
|
||||
(y (ly:stencil-extent m Y)))
|
||||
(ly:make-stencil (ly:stencil-expr m)
|
||||
(cons (car x) (+ (cdr x) amount))
|
||||
y)))
|
||||
(interpret-markup layout props (make-pad-x-left-markup amount arg))
|
||||
`(,amount . 0)))
|
||||
|
||||
#(define-markup-command (score-equal-height-with-indents layout props lines)
|
||||
(markup-list?)
|
||||
@@ -250,9 +236,103 @@
|
||||
(let ((text (ly:grob-property grob 'text)))
|
||||
|
||||
(grob-interpret-markup grob (if (string? text)
|
||||
(make-pad-right-markup -0.1 (make-tied-lyric-markup text))
|
||||
(make-pad-x-right-markup -0.1 (make-tied-lyric-markup text))
|
||||
text))))
|
||||
|
||||
Chord_lyrics_spacing_engraver =
|
||||
#(lambda (ctx)
|
||||
(let ((last-lyric-syllable #f)
|
||||
(lyric-width-since-last-chord 0)
|
||||
(music-columns-for-last-syllable 0)
|
||||
(last-printed-chord #f)
|
||||
(chord-width-since-last-lyric 0)
|
||||
(lyrics-seen-since-break #f)
|
||||
(have-a-rest #f)
|
||||
(stanza #f)
|
||||
(place-at-right-edge
|
||||
(lambda (grob anchor padding)
|
||||
(let ((anchor-width (interval-length (ly:grob-extent anchor anchor X))))
|
||||
(ly:grob-set-parent! grob X anchor)
|
||||
(ly:grob-set-property! grob 'X-offset (+ padding anchor-width))
|
||||
))))
|
||||
(make-engraver
|
||||
(listeners
|
||||
((multi-measure-rest-event engraver event)
|
||||
(set! have-a-rest #t)
|
||||
)
|
||||
((rest-event engraver event)
|
||||
(set! have-a-rest #t)
|
||||
)
|
||||
((lyric-event engraver event)
|
||||
(set! have-a-rest #f)
|
||||
(set! music-columns-for-last-syllable 0)
|
||||
)
|
||||
((break-event engraver event)
|
||||
(set! last-lyric-syllable #f)
|
||||
(set! lyric-width-since-last-chord 0)
|
||||
(set! music-columns-for-last-syllable 0)
|
||||
(set! last-printed-chord #f)
|
||||
(set! chord-width-since-last-lyric 0)
|
||||
(set! lyrics-seen-since-break #f)
|
||||
))
|
||||
(acknowledgers
|
||||
((musical-paper-column-interface this-engraver grob source-engraver)
|
||||
(set! music-columns-for-last-syllable (+ 1 music-columns-for-last-syllable))
|
||||
)
|
||||
((lyric-syllable-interface this-engraver grob source-engraver)
|
||||
(let ((syllable-width (interval-length (ly:grob-extent grob grob X))))
|
||||
(set! lyric-width-since-last-chord (+ lyric-width-since-last-chord syllable-width))
|
||||
)
|
||||
(if (> chord-width-since-last-lyric 0)
|
||||
(if lyrics-seen-since-break
|
||||
(ly:grob-set-property! grob 'extra-spacing-width
|
||||
(cons (- chord-width-since-last-lyric) (cdr (ly:grob-property grob 'extra-spacing-width '(0 . 0)))))
|
||||
(if last-printed-chord
|
||||
(let ((gap-for-starting-rest 2.0))
|
||||
(if stanza (ly:grob-set-property! stanza 'padding (+ 1 gap-for-starting-rest)))
|
||||
(ly:grob-set-parent! grob X last-printed-chord)
|
||||
(ly:grob-set-property! grob 'X-offset gap-for-starting-rest)
|
||||
)))
|
||||
)
|
||||
(set! last-lyric-syllable grob)
|
||||
(set! chord-width-since-last-lyric 0)
|
||||
(set! lyrics-seen-since-break #t)
|
||||
)
|
||||
((chord-name-interface this-engraver grob source-engraver)
|
||||
(if (not (and
|
||||
(boolean? (ly:grob-property grob 'begin-of-line-visible))
|
||||
(ly:grob-property grob 'begin-of-line-visible)
|
||||
lyrics-seen-since-break))
|
||||
(let* ((last-printed-chord-width (if last-printed-chord (interval-length (ly:grob-extent last-printed-chord last-printed-chord X)) 0))
|
||||
(chord-overwidth (- last-printed-chord-width lyric-width-since-last-chord))
|
||||
(chord-gap 0.5))
|
||||
(if have-a-rest
|
||||
(let ((chord-width (interval-length (ly:grob-extent grob grob X))))
|
||||
(if last-lyric-syllable
|
||||
(if (and last-printed-chord (> chord-overwidth 0))
|
||||
(place-at-right-edge grob last-printed-chord chord-gap)
|
||||
(place-at-right-edge grob last-lyric-syllable 0))
|
||||
(if last-printed-chord
|
||||
(place-at-right-edge grob last-printed-chord chord-gap)))
|
||||
(set! chord-width-since-last-lyric (+ chord-width-since-last-lyric chord-width chord-gap))
|
||||
))
|
||||
(if (and last-lyric-syllable last-printed-chord (> chord-overwidth 0))
|
||||
(ly:grob-set-property! last-lyric-syllable 'extra-spacing-width
|
||||
(cons (car (ly:grob-property last-lyric-syllable 'extra-spacing-width '(0 . 0))) (+ chord-gap chord-overwidth)))
|
||||
)
|
||||
(set! lyric-width-since-last-chord (* (if last-lyric-syllable (interval-length (ly:grob-extent last-lyric-syllable last-lyric-syllable X)) 0) (- 1 (/ 1.0 music-columns-for-last-syllable))))
|
||||
(set! last-printed-chord grob)
|
||||
(set! last-lyric-syllable #f)
|
||||
)
|
||||
(ly:grob-set-property! grob 'X-extent '(+inf.0 . -inf.0))
|
||||
)
|
||||
)
|
||||
((stanza-number-interface this-engraver grob source-engraver)
|
||||
(set! stanza grob)
|
||||
)
|
||||
)
|
||||
)))
|
||||
|
||||
#(define-markup-command (chordlyrics layout props lyrics) (ly:music?)
|
||||
#:properties ((verse-chords #{#})
|
||||
(verse-reference-voice #{#})
|
||||
@@ -272,14 +352,13 @@
|
||||
\new Lyrics \lyricsto "dummyvoice" { #lyrics }
|
||||
>>
|
||||
\layout {
|
||||
\verselayout
|
||||
#(let
|
||||
((custom-size (ly:output-def-lookup verselayout 'size #f)))
|
||||
(if custom-size (layout-set-staff-size custom-size)))
|
||||
$verselayout
|
||||
#(customized-layout verselayout)
|
||||
ragged-right = ##t
|
||||
\context {
|
||||
\Lyrics
|
||||
\override VerticalAxisGroup.nonstaff-relatedstaff-spacing.basic-distance = #verse-text-chord-distance
|
||||
\override VerticalAxisGroup.nonstaff-relatedstaff-spacing.padding = #(- verse-text-chord-distance songTextChordDistance)
|
||||
\override LyricText.parent-alignment-X = #LEFT
|
||||
\override LyricText.self-alignment-X = #LEFT
|
||||
\override LyricText.word-space = 0.8
|
||||
@@ -298,12 +377,17 @@
|
||||
% \override SpacingSpanner.strict-note-spacing = ##t
|
||||
\override SpacingSpanner.uniform-stretching = ##t
|
||||
\override SpacingSpanner.spacing-increment = 0
|
||||
% \override SpacingSpanner.packed-spacing = ##t
|
||||
\consists \Chord_lyrics_spacing_engraver
|
||||
% ChordPro engraver in Score context to collect all data
|
||||
\consists \ChordPro_score_collector
|
||||
\remove Bar_number_engraver
|
||||
\remove Mark_engraver
|
||||
\remove Jump_engraver
|
||||
\remove Volta_engraver
|
||||
\remove Parenthesis_engraver
|
||||
\remove Metronome_mark_engraver
|
||||
\remove Text_mark_engraver
|
||||
}
|
||||
\context {
|
||||
\Staff
|
||||
@@ -327,14 +411,6 @@
|
||||
\remove Note_heads_engraver
|
||||
\remove Script_engraver
|
||||
}
|
||||
\context {
|
||||
\NullVoice
|
||||
\consists Rest_engraver
|
||||
\omit Rest
|
||||
\undo \omit NoteHead
|
||||
\hide NoteHead
|
||||
\override NoteHead.X-extent = #'(0 . 0)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@@ -65,7 +65,10 @@ additionalPageNumbers =
|
||||
display-pages-list
|
||||
)
|
||||
|
||||
|
||||
% 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
|
||||
% page:page-number-string setzen dann klappts auch mit PDF Seiten
|
||||
#(define-markup-command (custom-page-number layout props label real-current-page-number)
|
||||
(symbol? number?)
|
||||
#:category other
|
||||
@@ -89,9 +92,10 @@ width may require additional tweaking.)"
|
||||
,(delay (ly:stencil-expr
|
||||
(let* ((display-page (assq-ref (build-display-pages-list layout) label))
|
||||
(real-current-page (if (negative? real-current-page-number) (real-page-number layout label) real-current-page-number))
|
||||
(number-type (ly:output-def-lookup layout 'page-number-type))
|
||||
(page-markup
|
||||
(if (assq-ref additional-page-switch-label-list label)
|
||||
(make-concat-markup (list (number-format 'arabic display-page)
|
||||
(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)))
|
||||
@@ -99,7 +103,7 @@ width may require additional tweaking.)"
|
||||
(find-earliest-additional-label (cdr rest-additional-page-switch-label-list))
|
||||
(caar rest-additional-page-switch-label-list)))
|
||||
))))))
|
||||
(number-format 'arabic (+ display-page (- real-current-page (real-page-number layout label))))
|
||||
(number-format number-type (+ display-page (- real-current-page (real-page-number layout label))))
|
||||
))
|
||||
(page-stencil (interpret-markup layout props page-markup))
|
||||
(gap (- (interval-length x-ext)
|
||||
|
||||
@@ -61,20 +61,9 @@
|
||||
;; 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)))))))))))))
|
||||
(ly:string-substitute "." ""
|
||||
(transliterate-de sorttext))))
|
||||
index-item-list))
|
||||
(make-music 'EventChord
|
||||
'page-marker #t
|
||||
@@ -101,7 +90,7 @@
|
||||
(for-each (lambda (category)
|
||||
(let* ((catsym (string->symbol category))
|
||||
(catlist (hashq-ref category-index-hash catsym
|
||||
(list (list label 'indexCategoryMarkup `(((rawtext . ,category))))))))
|
||||
(list (list label 'indexCategoryMarkup `(((combine-with-next . #t) (rawtext . ,category))))))))
|
||||
(if (assq catsym category-names)
|
||||
(hashq-set! category-index-hash catsym
|
||||
(cons (list label markup-symbol textoptions) catlist))
|
||||
@@ -125,7 +114,7 @@
|
||||
(for-each (lambda (authorID)
|
||||
(let* ((authorsym (string->symbol authorID))
|
||||
(authorlist (hashq-ref author-index-hash authorsym
|
||||
(list (list label 'indexAuthorMarkup `(((rawtext . ,authorID))))))))
|
||||
(list (list label 'indexAuthorMarkup `(((combine-with-next . #t) (rawtext . ,authorID))))))))
|
||||
(hashq-set! author-index-hash authorsym
|
||||
(cons (list label markup-symbol textoptions) authorlist))
|
||||
))
|
||||
@@ -229,7 +218,7 @@
|
||||
}
|
||||
|
||||
#(define (prepare-item-markup items layout)
|
||||
(map (lambda (index-item)
|
||||
(define (single-item-markup index-item)
|
||||
(let* ((label (car index-item))
|
||||
(index-markup (cadr index-item))
|
||||
(textoptions (caddr index-item))
|
||||
@@ -242,7 +231,16 @@
|
||||
#:override (cons 'index:alternative alternative)
|
||||
#:override (cons 'index:songnumber songnumber)
|
||||
(ly:output-def-lookup layout index-markup))))
|
||||
(items)))
|
||||
(if (null? items)
|
||||
items
|
||||
(let* ((index-item (car items))
|
||||
(combine-with-next (chain-assoc-get 'combine-with-next (caddr index-item) #f))
|
||||
(restitems (cdr items))
|
||||
(item-markup (single-item-markup index-item)))
|
||||
(if (and combine-with-next (not (null? restitems)))
|
||||
(cons (make-column-markup (list item-markup (single-item-markup (car restitems)))) (prepare-item-markup (cdr restitems) layout))
|
||||
(cons item-markup (prepare-item-markup restitems layout))))
|
||||
))
|
||||
|
||||
#(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" )
|
||||
@@ -256,7 +254,7 @@
|
||||
(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))))))
|
||||
(prepare-item-markup (items) layout))))))
|
||||
|
||||
indexItem =
|
||||
#(define-music-function (parser location sorttext text) (string? markup?)
|
||||
@@ -266,7 +264,7 @@ indexItem =
|
||||
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))
|
||||
(add-index-item! 'indexSectionMarkup (prepend-alist-chain 'combine-with-next #t (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)))
|
||||
@@ -443,6 +441,6 @@ headerToTOC = #(define-music-function (parser location header label) (ly:book? s
|
||||
; 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)))
|
||||
,(delay (let* ((table (ly:output-def-lookup layout 'label-absolute-page-table)))
|
||||
(generate-toc-csv (if (list? table) table '()))
|
||||
empty-stencil)))))
|
||||
|
||||
65
private_includes/book/transliteration.ily
Normal file
65
private_includes/book/transliteration.ily
Normal file
@@ -0,0 +1,65 @@
|
||||
#(define (transliterate-de str)
|
||||
"Gesamte Transliteration: entfernt Diakritika, ersetzt Sonderzeichen, ergibt ASCII-String."
|
||||
|
||||
(define (remove-diacritics s)
|
||||
(string-join
|
||||
(map (lambda (ch)
|
||||
(let ((code (char->integer ch)))
|
||||
;; Unicode-Bereich 0300–036F = Combining Diacritical Marks
|
||||
(if (and (>= code #x0300) (<= code #x036F))
|
||||
""
|
||||
(string ch))))
|
||||
(string->list (string-normalize-nfkd s)))
|
||||
""))
|
||||
|
||||
(define transliteration-table
|
||||
'(
|
||||
;; Deutsche Umlaute & ß
|
||||
("ä" . "ae") ("ö" . "oe") ("ü" . "ue")
|
||||
("Ä" . "Ae") ("Ö" . "Oe") ("Ü" . "Ue")
|
||||
("ß" . "ss")
|
||||
|
||||
;; Balkan & mitteleuropäische Sonderzeichen
|
||||
("Č" . "C") ("č" . "c")
|
||||
("Š" . "S") ("š" . "s")
|
||||
("Ž" . "Z") ("ž" . "z")
|
||||
("Đ" . "D") ("đ" . "d")
|
||||
("Ł" . "L") ("ł" . "l")
|
||||
("Ø" . "O") ("ø" . "o")
|
||||
("Æ" . "Ae") ("æ" . "ae")
|
||||
("Œ" . "Oe") ("œ" . "oe")
|
||||
|
||||
;; Kyrillische Buchstaben mit lateinischen Pendants
|
||||
("А" . "A") ("а" . "a")
|
||||
("Б" . "B") ("б" . "b")
|
||||
("В" . "V") ("в" . "v")
|
||||
("Г" . "G") ("г" . "g")
|
||||
("Д" . "D") ("д" . "d")
|
||||
("Е" . "E") ("е" . "e")
|
||||
("З" . "Z") ("з" . "z")
|
||||
("И" . "I") ("и" . "i")
|
||||
("К" . "K") ("к" . "k")
|
||||
("Л" . "L") ("л" . "l")
|
||||
("М" . "M") ("м" . "m")
|
||||
("Н" . "N") ("н" . "n")
|
||||
("О" . "O") ("о" . "o")
|
||||
("П" . "P") ("п" . "p")
|
||||
("Р" . "R") ("р" . "r")
|
||||
("С" . "S") ("с" . "s")
|
||||
("Т" . "T") ("т" . "t")
|
||||
("У" . "U") ("у" . "u")
|
||||
("Ф" . "F") ("ф" . "f")
|
||||
("Х" . "Kh") ("х" . "kh")
|
||||
("Ц" . "Ts") ("ц" . "ts")
|
||||
("Ч" . "Ch") ("ч" . "ch")
|
||||
("Ш" . "Sh") ("ш" . "sh")
|
||||
("Щ" . "Sch") ("щ" . "sch")
|
||||
("Я" . "Ja") ("я" . "ja")
|
||||
("Ю" . "Ju") ("ю" . "ju")
|
||||
("Й" . "J") ("й" . "j")
|
||||
))
|
||||
|
||||
(remove-diacritics
|
||||
(fold (lambda (pair acc)
|
||||
(ly:string-substitute (car pair) (cdr pair) acc))
|
||||
str transliteration-table)))
|
||||
@@ -1,3 +1,4 @@
|
||||
\include "../private_includes/book/book_include.ily"
|
||||
\include "../private_includes/book/transliteration.ily"
|
||||
\include "../private_includes/book/toc_include.ily"
|
||||
\include "../private_includes/book/appendix.ily"
|
||||
@@ -1,8 +1,10 @@
|
||||
% set the speed of the midi music
|
||||
#(define midiQuarterNoteSpeed (if (defined? 'midiQuarterNoteSpeed) midiQuarterNoteSpeed 90))
|
||||
|
||||
MUSIC = { \transposable #TRANSPOSITION \MUSIC }
|
||||
|
||||
LAYOUT = \layout {
|
||||
\LAYOUT
|
||||
#(customized-layout LAYOUT)
|
||||
}
|
||||
|
||||
verselayout = \layout {
|
||||
\LAYOUT
|
||||
\context {
|
||||
@@ -11,18 +13,12 @@ verselayout = \layout {
|
||||
}
|
||||
}
|
||||
|
||||
LAYOUT = \layout {
|
||||
\LAYOUT
|
||||
#(let
|
||||
((custom-size (ly:output-def-lookup LAYOUT 'size #f)))
|
||||
(if custom-size (layout-set-staff-size custom-size)))
|
||||
}
|
||||
|
||||
TEXT = \markuplist {
|
||||
\override #`(transposition . ,TRANSPOSITION)
|
||||
\override #`(verselayout . ,verselayout)
|
||||
\override #`(verse-chords . ,#{ \chords { \verseChords } #})
|
||||
\override #`(verse-reference-voice . ,#{ \global \firstVoice #})
|
||||
\handle-tag-groups \recordedTagGroups
|
||||
\TEXT
|
||||
}
|
||||
|
||||
@@ -34,6 +30,7 @@ TEXT = \markuplist {
|
||||
\override #`(verselayout . ,verselayout)
|
||||
\override #`(verse-chords . ,#{ \chords { \verseChords } #})
|
||||
\override #`(verse-reference-voice . ,#{ \global \firstVoice #})
|
||||
\handle-tag-groups \recordedTagGroups
|
||||
#text
|
||||
}
|
||||
#})
|
||||
@@ -44,6 +41,20 @@ TEXT = \markuplist {
|
||||
TEXT_PAGES
|
||||
(list TEXT))))
|
||||
|
||||
%% Add invisible ChordPro write trigger to last TEXT_PAGES markuplist
|
||||
#(when (and (defined? 'chordpro-export-enabled) chordpro-export-enabled (pair? TEXT_PAGES))
|
||||
(let* ((last-index (- (length TEXT_PAGES) 1))
|
||||
(last-page (list-ref TEXT_PAGES last-index))
|
||||
(modified-last-page #{
|
||||
\markuplist {
|
||||
#last-page
|
||||
\chordpro-delayed-write
|
||||
}
|
||||
#}))
|
||||
(set! TEXT_PAGES
|
||||
(append (list-head TEXT_PAGES last-index)
|
||||
(list modified-last-page)))))
|
||||
|
||||
#(define (add-text-pages text-pages)
|
||||
(if (pair? text-pages)
|
||||
(begin
|
||||
@@ -60,21 +71,38 @@ TEXT = \markuplist {
|
||||
(if header (set! $defaultheader header))
|
||||
(if paper (set! $defaultpaper paper))
|
||||
)
|
||||
|
||||
;; 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
|
||||
;; This will write relative to current working directory (same as PDF)
|
||||
(let ((output-name (ly:parser-output-name)))
|
||||
(set! chordpro-current-filename output-name))
|
||||
|
||||
;; Try to extract metadata from basicSongInfo \header block
|
||||
(when (defined? 'basicSongInfo)
|
||||
(let* ((header-alist (ly:module->alist basicSongInfo))
|
||||
(title (assoc-ref header-alist 'title))
|
||||
(authors (assoc-ref header-alist 'authors)))
|
||||
(when title
|
||||
(set! chordpro-header-title
|
||||
(if (markup? title)
|
||||
(markup->string title)
|
||||
(if (string? title) title "Untitled"))))
|
||||
(when authors
|
||||
(set! chordpro-header-authors authors)))))
|
||||
|
||||
(add-score #{
|
||||
\score {
|
||||
\MUSIC
|
||||
\layout { \LAYOUT }
|
||||
}#})
|
||||
(add-text-pages TEXT_PAGES)
|
||||
|
||||
(add-score #{
|
||||
\score {
|
||||
\unfoldRepeats { \MUSIC \INLINESCOREMUSIC }
|
||||
\midi {
|
||||
\context {
|
||||
\Score
|
||||
% Tempo des midi files
|
||||
tempoWholesPerMinute = #(/ midiQuarterNoteSpeed 4)
|
||||
}
|
||||
\context {
|
||||
\Staff
|
||||
\remove "Staff_performer"
|
||||
|
||||
Reference in New Issue
Block a user