scm/chord-generic-names.scm

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