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 omit-root)
  81   "Transform sequential music SEQ of type <<c d e>>-\markup{ foobar }
  82 to (cons CDE-PITCHES FOOBAR-MARKUP), or to (cons DE-PITCHES
  83 FOOBAR-MARKUP) if OMIT-ROOT.
  84 "
  85   (define (chord-to-exception-entry m)
  86     (let* ((elts (ly:get-mus-property m 'elements))
  87            (pitches (map (lambda (x) (ly:get-mus-property x 'pitch))
  88                          (filter-list
  89                           (lambda (y) (memq 'note-event
  90                                             (ly:get-mus-property y 'types)))
  91                           elts)))
  92            (sorted (sort pitches ly:pitch<?))
  93            (root (car sorted))
  94            ;; ugh?
  95            ;;(diff (ly:pitch-diff root (ly:make-pitch -1 0 0)))
  96            ;; FIXME.  This results in #<Pitch c> ...,
  97            ;; but that is what we need because default octave for
  98            ;; \chords has changed to c' too?
  99            (diff (ly:pitch-diff root (ly:make-pitch 0 0 0)))
 100            (normalized (map (lambda (x) (ly:pitch-diff x diff)) sorted))
 101            (texts (map (lambda (x) (ly:get-mus-property x 'text))
 102                        (filter-list
 103                         (lambda (y) (memq 'text-script-event
 104                                           (ly:get-mus-property y 'types)))
 105                         elts)))
 106            ;;(text (if (null? texts) #f (if (= length texts) 1)
 107            ;;        (car texts) (reverse texts))))
 108            (text (if (null? texts) #f (if omit-root (car texts) texts))))
 109       (cons (if omit-root (cdr normalized) normalized) text)))
 110
 111   (define (is-req-chord? m)
 112     (and
 113      (memq 'event-chord (ly:get-mus-property m 'types))
 114      (not (equal? (ly:make-moment 0 1) (ly:get-music-length m)))))
 115
 116   (let* ((elts (filter-list is-req-chord? (ly:get-mus-property seq 'elements)))
 117          (alist (map chord-to-exception-entry elts)))
 118     (filter-list (lambda (x) (cdr x)) alist)))
 119
 120
 121 (define-public (new-chord-name-brew-molecule grob)
 122   (let*
 123       (
 124        (ws (ly:get-grob-property grob 'word-space))
 125        (markup (ly:get-grob-property grob 'text))
 126        (molecule (interpret-markup grob
 127                                    (cons '((word-space . 0.0))
 128                                          (Font_interface::get_property_alist_chain grob))
 129                                    markup))
 130        )
 131
 132     ;;
 133     ;; chord names aren't in staffs, so WS is in global staff space.
 134     (if (number? ws)
 135         (ly:molecule-combine-at-edge
 136          molecule
 137          X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
 138          0.0)
 139         molecule)
 140     ))
 141
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143
 144 (define-public (set-chord-name-style sym)
 145   "Return music expressions that set the chord naming style. For
 146 inline use in .ly file"
 147
 148   (define (chord-name-style-setter function style)
 149     (context-spec-music
 150      (make-sequential-music
 151       (list (make-property-set 'chordNameFunction function)
 152             (make-property-set 'chordNameStyle style)))
 153      "ChordNames"))
 154
 155   (ly:export
 156    (case sym
 157      ((ignatzek) (chord-name-style-setter ignatzek-chord-names))
 158      ((banter) (chord-name-style-setter double-plus-new-chord->markup 'banter))
 159      ((jazz) (chord-name-style-setter double-plus-new-chord->markup 'jazz)))))