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