scm/chord-generic-names.scm

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