scm/chord-generic-names.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2010 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18
  19 ;;;; NOTE: this is experimental code
  20 ;;;; Base and inversion are ignored.
  21 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
  22 ;;;; see input/test/chord-names-dpnj.ly
  23
  24 (define (markup-or-empty-markup markup)
  25   "Return MARKUP if markup, else empty-markup"
  26   (if (markup? markup) markup empty-markup))
  27
  28 (define (conditional-kern-before markup bool amount)
  29   "Add AMOUNT of space before MARKUP if BOOL is true."
  30   (if bool
  31       (make-line-markup
  32        (list (make-hspace-markup amount)
  33              markup))
  34       markup))
  35
  36 (define-public (banter-chord-names pitches bass inversion context)
  37   (ugh-compat-double-plus-new-chord->markup
  38    'banter pitches bass inversion context '()))
  39
  40 (define-public (jazz-chord-names pitches bass inversion context)
  41   (ugh-compat-double-plus-new-chord->markup
  42    'jazz pitches bass inversion context '()))
  43
  44 (define-public (ugh-compat-double-plus-new-chord->markup
  45                 style pitches bass inversion context options)
  46   "Entry point for New_chord_name_engraver.
  47
  48 FIXME: func, options/context have changed
  49  See
  50 double-plus-new-chord-name.scm for the signature of STYLE.  PITCHES,
  51 BASS and INVERSION are lily pitches.  OPTIONS is an alist-alist (see
  52 input/test/dpncnt.ly).
  53  "
  54
  55   (define (step-nr pitch)
  56     (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
  57                         (ly:pitch-notename pitch)))
  58            (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
  59                         (ly:pitch-notename (car pitches)))))
  60       (+ 1 (- pitch-nr root-nr))))
  61
  62   (define (next-third pitch)
  63     (ly:pitch-transpose pitch
  64                         (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
  65                                                    (= (step-nr pitch) 5))
  66                                                FLAT 0))))
  67
  68   (define (step-alteration pitch)
  69     (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
  70            (normalized-pitch (ly:pitch-transpose pitch diff))
  71            (alteration (ly:pitch-alteration normalized-pitch)))
  72       (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
  73
  74   (define (pitch-unalter pitch)
  75     (let ((alteration (step-alteration pitch)))
  76       (if (= alteration 0)
  77           pitch
  78           (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
  79                          (- (ly:pitch-alteration pitch) alteration)))))
  80
  81   (define (step-even-or-altered? pitch)
  82     (let ((nr (step-nr pitch)))
  83       (if (!= (modulo nr 2) 0)
  84           (!= (step-alteration pitch) 0)
  85           #t)))
  86
  87   (define (step->markup-plusminus pitch)
  88     (make-line-markup
  89      (list
  90       (make-simple-markup (number->string (step-nr pitch)))
  91       (make-simple-markup
  92        (case (step-alteration pitch)
  93          ((DOUBLE-FLAT) "--")
  94          ((FLAT) "-")
  95          ((NATURAL) "")
  96          ((SHARP) "+")
  97          ((DOUBLE-SHARP) "++"))))))
  98
  99   (define (step->markup-accidental pitch)
 100     (make-line-markup
 101      (list (accidental->markup (step-alteration pitch))
 102            (make-simple-markup (number->string (step-nr pitch))))))
 103
 104   (define (step->markup-ignatzek pitch)
 105     (make-line-markup
 106      (if (and (= (step-nr pitch) 7)
 107               (= (step-alteration pitch) 1))
 108          (list (ly:context-property context 'majorSevenSymbol))
 109          (list (accidental->markup (step-alteration pitch))
 110                (make-simple-markup (number->string (step-nr pitch)))))))
 111
 112   ;; tja, kennok
 113   (define (make-sub->markup step->markup)
 114     (lambda (pitch)
 115       (make-line-markup (list (make-simple-markup "no")
 116                               (step->markup pitch)))))
 117
 118   (define (step-based-sub->markup step->markup pitch)
 119     (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
 120
 121   (define (get-full-list pitch)
 122     (if (<= (step-nr pitch) (step-nr (last pitches)))
 123         (cons pitch (get-full-list (next-third pitch)))
 124         '()))
 125
 126   (define (get-consecutive nr pitches)
 127     (if (pair? pitches)
 128         (let* ((pitch-nr (step-nr (car pitches)))
 129                (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
 130           (if (<= pitch-nr nr)
 131               (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
 132               '()))
 133         '()))
 134
 135   (define (full-match exceptions)
 136     (if (pair? exceptions)
 137         (let* ((e (car exceptions))
 138                (e-pitches (car e)))
 139           (if (equal? e-pitches pitches)
 140               e
 141               (full-match (cdr exceptions))))
 142         #f))
 143
 144   (define (partial-match exceptions)
 145     (if (pair? exceptions)
 146         (let* ((e (car exceptions))
 147                (e-pitches (car e)))
 148           (if (equal? e-pitches (take pitches (length e-pitches)))
 149               e
 150               (partial-match (cdr exceptions))))
 151         #f))
 152
 153   (if #f (begin
 154            (write-me "pitches: " pitches)))
 155   (let* ((full-exceptions
 156           (ly:context-property context 'chordNameExceptionsFull))
 157          (full-exception (full-match full-exceptions))
 158          (full-markup (if full-exception (cadr full-exception) '()))
 159          (partial-exceptions
 160           (ly:context-property context 'chordNameExceptionsPartial))
 161          (partial-exception (partial-match partial-exceptions))
 162          (partial-pitches (if partial-exception (car partial-exception) '()))
 163          (partial-markup-prefix
 164           (if partial-exception (markup-or-empty-markup
 165                                  (cadr partial-exception)) empty-markup))
 166          (partial-markup-suffix
 167           (if (and partial-exception (pair? (cddr partial-exception)))
 168               (markup-or-empty-markup (caddr partial-exception)) empty-markup))
 169          (root (car pitches))
 170          (full (get-full-list root))
 171          ;; kludge alert: replace partial matched lower part of all with
 172          ;; 'normal' pitches from full
 173          ;; (all pitches)
 174          (all (append (take full (length partial-pitches))
 175                       (drop pitches (length partial-pitches))))
 176
 177          (highest (last all))
 178          (missing (list-minus full (map pitch-unalter all)))
 179          (consecutive (get-consecutive 1 all))
 180          (rest (list-minus all consecutive))
 181          (altered (filter step-even-or-altered? all))
 182          (cons-alt (filter step-even-or-altered? consecutive))
 183          (base (list-minus consecutive altered)))
 184
 185
 186     (if #f (begin
 187              (write-me "full:" full)
 188               ;; (write-me "partial-pitches:" partial-pitches)
 189               (write-me "full-markup:" full-markup)
 190               (write-me "partial-markup-perfix:" partial-markup-prefix)
 191               (write-me "partial-markup-suffix:" partial-markup-suffix)
 192               (write-me "all:" all)
 193               (write-me "altered:" altered)
 194               (write-me "missing:" missing)
 195               (write-me "consecutive:" consecutive)
 196               (write-me "rest:" rest)
 197               (write-me "base:" base)))
 198
 199     (case style
 200       ((banter)
 201        ;;    root
 202        ;;    + steps:altered + (highest all -- if not altered)
 203        ;;    + subs:missing
 204
 205        (let* ((root->markup (assoc-get
 206                               'root->markup options note-name->markup))
 207               (step->markup (assoc-get
 208                              'step->markup options step->markup-plusminus))
 209               (sub->markup (assoc-get
 210                             'sub->markup options
 211                             (lambda (x)
 212                               (step-based-sub->markup step->markup x))))
 213               (sep (assoc-get
 214                     'separator options (make-simple-markup "/"))))
 215
 216          (if
 217           (pair? full-markup)
 218           (make-line-markup (list (root->markup root) full-markup))
 219
 220           (make-line-markup
 221            (list
 222             (root->markup root)
 223             partial-markup-prefix
 224             (make-normal-size-super-markup
 225              (markup-join
 226               (apply append
 227                      (map step->markup
 228                           (append altered
 229                                   (if (and (> (step-nr highest) 5)
 230                                            (not
 231                                             (step-even-or-altered? highest)))
 232                                       (list highest) '())))
 233                       (list partial-markup-suffix)
 234                      (list (map sub->markup missing)))
 235               sep)))))))
 236
 237
 238       ((jazz)
 239        ;;    root
 240        ;;    + steps:(highest base) + cons-alt
 241        ;;    + 'add'
 242        ;;    + steps:rest
 243        (let* ((root->markup (assoc-get
 244                               'root->markup options note-name->markup))
 245               (step->markup
 246                (assoc-get
 247                 ;; FIXME: ignatzek
 248                 ;;'step->markup options step->markup-accidental))
 249                 'step->markup options step->markup-ignatzek))
 250               (sep (assoc-get
 251                     'separator options (make-simple-markup " ")))
 252               (add-prefix (assoc-get 'add-prefix options
 253                                              (make-simple-markup " add"))))
 254
 255          (if
 256           (pair? full-markup)
 257           (make-line-markup (list (root->markup root) full-markup))
 258
 259           (make-line-markup
 260            (list
 261             (root->markup root)
 262             partial-markup-prefix
 263             (make-normal-size-super-markup
 264              (make-line-markup
 265               (list
 266
 267                ;; kludge alert: omit <= 5
 268                ;;(markup-join (map step->markup
 269                ;;                        (cons (last base) cons-alt)) sep)
 270
 271                ;; This fixes:
 272                ;;  c     C5       -> C
 273                ;;  c:2   C5 2     -> C2
 274                ;;  c:3-  Cm5      -> Cm
 275                ;;  c:6.9 C5 6add9 -> C6 add 9 (add?)
 276                ;;  ch = \chords { c c:2 c:3- c:6.9^7 }
 277                (markup-join (map step->markup
 278                                  (let ((tb (last base)))
 279                                    (if (> (step-nr tb) 5)
 280                                        (cons tb cons-alt)
 281                                        cons-alt))) sep)
 282
 283                (if (pair? rest)
 284                    add-prefix
 285                    empty-markup)
 286                (markup-join (map step->markup rest) sep)
 287                partial-markup-suffix))))))))
 288
 289        (else empty-markup))))