Function to create WYGIWYM chord names

This function is an update to an earlier version which can be found here: http://lists.gnu.org/archive/html/lilypond-user/2009-02/msg00293.html

The function is customised to work with a special font that can also be found in the above link. It shouldn't be too difficult to get the function to work with other fonts.

I created this function because the ChordNames context generates chord symbols only by chord entry (<c e g>), which often leads to misinterpretation and strange chord symbols as a result.

What this function basically does is taking note-input and converting it to a Lyrics context. For example, c-"7" will print the C7 chord symbol.

The advantage of this function is that the input can still be transposed before it gets converted, i.e., \transpose c d c-"7" will print the D7 chord symbol.

The following entries are possible:

• c → C
• c-"7" → C7
• <c e> → C/E
• <c e&>-"7" → C7/E
• r → N.C.
• s → (empty)
• s-"text" → text [not affected by transposition]

These three additional functions work with any of the above (except for skip).

• \parenLeft c → (C
• \parenRight c → C)
• \parenBoth c → (C)

\version "2.24"

%LSR created by TaoCG

#(define (music-elts x)
   (ly:music-property x 'elements))

#(define (EventChord? x)
   (eq? (ly:music-property x 'name) 'EventChord))

#(define (NoteEvent? x)
   (eq? (ly:music-property x 'name) 'NoteEvent))

#(define (RestEvent? x)
   (eq? (ly:music-property x 'name) 'RestEvent))

#(define (SkipEvent? x)
   (eq? (ly:music-property x 'name) 'SkipEvent))

#(define (root-name x)
   (let ((n (ly:pitch-notename (ly:music-property x 'pitch))))
     (case n
       ((0) "C")
       ((1) "D")
       ((2) "E")
       ((3) "F")
       ((4) "G")
       ((5) "A")
       ((6) "B"))))

#(define (root-alter x)
   (let ((a (ly:pitch-alteration (ly:music-property x 'pitch))))
     (case a
       ((-1) "<")
       ((-1/2) "b")
       ((0) "")
       ((1/2) "#")
       ((1) ">"))))

#(define (bass-name x)
   (let ((n (ly:pitch-notename (ly:music-property x 'pitch))))
     (case n
       ((0) "e")
       ((1) "r")
       ((2) "t")
       ((3) "z")
       ((4) "u")
       ((5) "q")
       ((6) "w"))))

#(define (bass-alter x)
   (let ((a (ly:pitch-alteration (ly:music-property x 'pitch))))
     (case a
       ((-1) ";")
       ((-1/2) ",")
       ((0) "")
       ((1/2) "'")
       ((1) "\""))))

#(define (symbolize-chord music)
   (if (EventChord? music)
     (let* ((i (length (music-elts music)))
                (event (car (music-elts music)))
                (dur (ly:music-property event 'duration))
                (root "")
                (bass "")
                (r-alt "")
                (b-alt "")
                (suffix "")
                (paren-left "")
                (paren-right ""))
           (when (NoteEvent? event)
             (set! root (root-name event))
       (set! r-alt (root-alter event))
       (if (eq? (ly:music-property event 'parenleft) #t)
           (set! paren-left "["))
       (if (eq? (ly:music-property event 'parenright) #t)
           (set! paren-right "]"))
       (if (= i 2)
           (let ((event-two (cadr (music-elts music))))
             (if (NoteEvent? event-two)
               (when (NoteEvent? event-two)
                 (set! bass (string-append "_" (bass-name event-two)))
                 (set! b-alt (bass-alter event-two)))
               (set! suffix (ly:music-property event-two 'text)))))
       (if (= i 3)
           (let ((event-two (cadr (music-elts music)))
                 (event-three (car (cddr (music-elts music)))))
             (set! bass (string-append "_" (bass-name event-two)))
             (set! b-alt (bass-alter event-two))
             (set! suffix (ly:music-property event-three 'text)))))
           (when (RestEvent? event)
             (set! root "N.C.")
       (if (eq? (ly:music-property event 'parenleft) #t)
           (set! paren-left "["))
       (if (eq? (ly:music-property event 'parenright) #t)
           (set! paren-right "]")))
           (if (and (SkipEvent? event) (> i 1))
       (set! suffix (ly:music-property (cadr (music-elts music)) 'text)))
             (set! music (make-music
                           'LyricEvent
                   'duration dur
                   'text
                   (string-append
                     paren-left root r-alt suffix bass b-alt paren-right)))))
   music)

%% Updaters Remark:
%% Simply using `event-chord-wrap!' to get old behaviour back is pretty lazy.
%% Alas, do we need this snippet anymore at all? --Harm
chordSymbols =
#(define-music-function (music) (ly:music?)
   (music-map
     (lambda (x) (symbolize-chord x))
     (event-chord-wrap! music)))

parenLeft =
#(define-music-function (music) (ly:music?)
   (ly:music-set-property!
    (if (EventChord? music)
        (car (ly:music-property music 'elements))
        music)
    'parenleft #t)
     music)

parenRight =
#(define-music-function (music) (ly:music?)
   (ly:music-set-property!
    (if (EventChord? music)
        (car (ly:music-property music 'elements))
        music)
    'parenright #t)
     music)

parenBoth =
#(define-music-function (music) (ly:music?)
  (parenLeft (parenRight music)))


<<
  \new Staff = "s" \new Voice = "v" { g'2 c' f'1 bes'2 es' a' d' }
  \new Lyrics \with { alignAboveContext = "s" } {
    %\override LyricText.font-name = "JazzChords"
    \set associatedVoice = "v"
    \chordSymbols {
      \transpose c f {
        \parenLeft
        d2-"m7"
        <g b>-"13"
        c1-"M"

        s2
        s-"|: A7 :|"
        \parenRight
        r
      }
    }
  }
>>