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