scm/chord-name.scm

   1 ;;;
   2 ;;; chord-name.scm --  chord name utility functions
   3 ;;;
   4 ;;; source file of the GNU LilyPond music typesetter
   5 ;;;
   6 ;;; (c)  2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;; Han-Wen Nienhuys
   8
   9 (define (natural-chord-alteration p)
  10   "Return the natural alteration for step P."
  11   (if (= (ly:pitch-steps p) 6)
  12       -1
  13       0))
  14
  15
  16 (define-public (alteration->text-accidental-markup alteration)
  17   (make-smaller-markup
  18    (make-raise-markup
  19     (if (= alteration -1)
  20         0.3
  21         0.6)
  22     (make-musicglyph-markup
  23      (string-append "accidentals-" (number->string alteration))))))
  24
  25 (define (accidental->markup alteration)
  26   "Return accidental markup for ALTERATION."
  27   (if (= alteration 0)
  28       (make-line-markup (list empty-markup))
  29       (conditional-kern-before
  30        (alteration->text-accidental-markup alteration)
  31        (= alteration -1) 0.2
  32        )))
  33
  34
  35 (define-public (note-name->markup pitch)
  36   "Return pitch markup for PITCH."
  37   (make-line-markup
  38    (list
  39     (make-simple-markup
  40      (vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename pitch)))
  41     (make-normal-size-super-markup
  42      (accidental->markup (ly:pitch-alteration pitch))))))
  43
  44
  45 (define-public ((chord-name->german-markup B-instead-of-Bb) pitch)
  46   "Return pitch markup for PITCH, using german note names.
  47    If B-instead-of-Bb is set to #t real german names are returned.
  48    Otherwise semi-german names (with Bb and below keeping the british names)
  49 "
  50   (let* ((name (ly:pitch-notename pitch))
  51          (alt (ly:pitch-alteration pitch))
  52          (n-a (if (member (cons name alt) '((6 . -1) (6 . -2)))
  53                  (cons 7 (+ (if B-instead-of-Bb 1 0) alt))
  54                  (cons name alt))))
  55     (make-line-markup
  56      (list
  57       (make-simple-markup
  58        (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a)))
  59       (make-normal-size-super-markup
  60        (accidental->markup (cdr n-a)))))))
  61
  62
  63 (define-public (note-name->german-markup  pitch)
  64   (let* ((name (ly:pitch-notename pitch))
  65          (alt (ly:pitch-alteration pitch))
  66          (n-a (if (member (cons name alt) '((6 . -1) (6 . -2)))
  67                   (cons 7 (+ 1 alt))
  68                   (cons name alt))))
  69     (make-line-markup
  70      (list
  71       (string-append
  72        (list-ref '("c" "d" "e" "f" "g" "a" "h" "b") (car n-a))
  73        (if (or (equal? (car n-a) 2) (equal? (car n-a) 5))
  74            (list-ref '( "ses"  "s" "" "is" "isis") (+ 2 (cdr n-a)))
  75            (list-ref '("eses" "es" "" "is" "isis") (+ 2 (cdr n-a)))))))))
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;;
  79
  80 (define-public (sequential-music-to-chord-exceptions seq)
  81   "Transform sequential music of <<a b c>>-\markup{ foobar } type to
  82  (cons ABC-PITCHES FOOBAR-MARKUP)
  83  "
  84
  85   (define (is-req-chord? m)
  86     (and
  87      (memq 'event-chord (ly:get-mus-property m 'types))
  88      (not (equal? (ly:make-moment 0 1) (ly:get-music-length m)))
  89     ))
  90
  91   (define (chord-to-exception-entry m)
  92     (let*
  93         (
  94          (elts   (ly:get-mus-property m 'elements))
  95          (pitches (map
  96                    (lambda (x)
  97                      (ly:get-mus-property x 'pitch)
  98                      )
  99                    (filter-list
 100                     (lambda (y) (memq 'note-event (ly:get-mus-property y 'types)))
 101                     elts)))
 102          (sorted  (sort pitches ly:pitch<? ))
 103          (root (car sorted))
 104          (non-root (map (lambda (x) (ly:pitch-diff x root)) (cdr sorted)))
 105          (texts (map
 106                  (lambda (x)
 107                    (ly:get-mus-property x 'text)
 108                    )
 109
 110                  (filter-list
 111                   (lambda (y)
 112                     (memq 'text-script-event
 113                           (ly:get-mus-property y 'types))) elts)
 114                  ))
 115          (text (if (null? texts)
 116                    #f
 117                    (car texts)))
 118
 119          )
 120       (cons non-root text)
 121     ))
 122
 123   (let*
 124     (
 125      (elts (filter-list is-req-chord? (ly:get-mus-property seq 'elements)))
 126      (alist (map chord-to-exception-entry elts))
 127      )
 128     (filter-list (lambda (x) (cdr x)) alist)
 129   ))
 130
 131
 132
 133
 134 (define-public (new-chord-name-brew-molecule grob)
 135   (let*
 136       (
 137        (ws (ly:get-grob-property grob 'word-space))
 138        (markup (ly:get-grob-property grob 'text))
 139        (molecule (interpret-markup grob
 140                                    (cons '((word-space . 0.0))
 141                                          (Font_interface::get_property_alist_chain grob))
 142                                    markup))
 143        )
 144
 145     ;;
 146     ;; chord names aren't in staffs, so WS is in global staff space.
 147     (if (number? ws)
 148         (ly:molecule-combine-at-edge
 149          molecule
 150          X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
 151          0.0)
 152         molecule)
 153     ))
 154
 155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 156
 157 (define-public (set-chord-name-style sym)
 158   "Return music expressions that set the chord naming style. For
 159 inline use in .ly file"
 160
 161   (define (chord-name-style-setter function exceptions)
 162     (context-spec-music
 163      (make-sequential-music
 164       (list (make-property-set 'chordNameFunction function)
 165             (make-property-set 'chordNameExceptions exceptions)))
 166      "ChordNames"
 167      )
 168     )
 169
 170   (ly:export
 171    (case sym
 172      ((ignatzek)
 173       (chord-name-style-setter ignatzek-chord-names
 174                                '()))
 175      ((banter)
 176       (chord-name-style-setter double-plus-new-chord->markup-banter
 177        chord::exception-alist-banter))
 178
 179      ((jazz)
 180       (chord-name-style-setter double-plus-new-chord->markup-jazz
 181        chord::exception-alist-jazz))
 182      )))
 183
 184 ;; can't put this in double-plus-new-chord-name.scm, because we can't
 185 ;; ly:load that very easily.
 186 (define-public (set-double-plus-new-chord-name-style style options)
 187   "Return music expressions that set the chord naming style. For
 188 inline use in .ly file"
 189
 190   (define (chord-name-style-setter function)
 191     (context-spec-music
 192      (make-sequential-music
 193       (list (make-property-set 'chordNameFunction function)
 194
 195             ;; urg , misuse of chordNameExceptions function.
 196             (make-property-set 'chordNameExceptions options)))
 197      "ChordNames"))
 198
 199   (ly:export
 200    (case style
 201      ((banter)
 202       (chord-name-style-setter double-plus-new-chord->markup-banter))
 203
 204      ((jazz)
 205       (chord-name-style-setter double-plus-new-chord->markup-jazz)))))
 206