scm/chord-ignatzek-names.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2015  Han-Wen Nienhuys <hanwen@xs4all.nl>
   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
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;; jazz-part 2
  24 ;;
  25 ;; after Klaus Ignatzek,   Die Jazzmethode fuer Klavier 1.
  26 ;;
  27 ;; The idea is: split chords into
  28 ;;
  29 ;;  ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
  30 ;;
  31 ;; and put that through a layout routine.
  32 ;;
  33 ;; the split is a procedural process, with lots of set!.
  34 ;;
  35
  36
  37 ;; todo: naming is confusing: steps  (0 based) vs. steps (1 based).
  38 (define (pitch-step p)
  39   "Musicological notation for an interval.  Eg. C to D is 2."
  40   (+ 1 (ly:pitch-steps p)))
  41
  42 (define (get-step x ps)
  43   "Does PS have the X step? Return that step if it does."
  44   (if (null? ps)
  45       #f
  46       (if (= (- x 1) (ly:pitch-steps (car ps)))
  47           (car ps)
  48           (get-step x (cdr ps)))))
  49
  50 (define (replace-step p ps)
  51   "Copy PS, but replace the step of P in PS."
  52   (if (null? ps)
  53       '()
  54       (let* ((t (replace-step p (cdr ps))))
  55         (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
  56             (cons p t)
  57             (cons (car ps) t)))))
  58
  59 (define (remove-step x ps)
  60   "Copy PS, but leave out the Xth step."
  61   (if (null? ps)
  62       '()
  63       (let* ((t (remove-step x (cdr ps))))
  64         (if (= (- x 1) (ly:pitch-steps (car ps)))
  65             t
  66             (cons (car ps) t)))))
  67
  68
  69 (define-public (ignatzek-chord-names
  70                 in-pitches bass inversion
  71                 context)
  72
  73   (define (remove-uptil-step x ps)
  74     "Copy PS, but leave out everything below the Xth step."
  75     (if (null? ps)
  76         '()
  77         (if (< (ly:pitch-steps (car ps)) (- x 1))
  78             (remove-uptil-step x (cdr ps))
  79             ps)))
  80
  81   (define name-root (ly:context-property context 'chordRootNamer))
  82   (define name-note
  83     (let ((nn (ly:context-property context 'chordNoteNamer)))
  84       (if (eq? nn '())
  85           ;; replacing the next line with name-root gives guile-error...? -rz
  86
  87           ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
  88           (ly:context-property context 'chordRootNamer)
  89           ;; name-root
  90           nn)))
  91
  92   (define (is-natural-alteration? p)
  93     (= (natural-chord-alteration p) (ly:pitch-alteration p)))
  94
  95   (define (ignatzek-format-chord-name
  96            root
  97            prefix-modifiers
  98            main-name
  99            alteration-pitches
 100            addition-pitches
 101            suffix-modifiers
 102            bass-pitch
 103            lowercase-root?)
 104
 105     "Format for the given (lists of) pitches.  This is actually more
 106 work than classifying the pitches."
 107
 108     (define (filter-main-name p)
 109       "The main name: don't print anything for natural 5 or 3."
 110       (if
 111        (or (not (ly:pitch? p))
 112            (and (is-natural-alteration? p)
 113                 (or (= (pitch-step p) 5)
 114                     (= (pitch-step p) 3))))
 115        '()
 116        (list (name-step p))))
 117
 118     (define (glue-word-to-step word x)
 119       (make-line-markup
 120        (list
 121         (make-simple-markup word)
 122         (name-step x))))
 123
 124     (define (suffix-modifier->markup mod)
 125       (if (or (= 4 (pitch-step mod))
 126               (= 2 (pitch-step mod)))
 127           (glue-word-to-step "sus" mod)
 128           (glue-word-to-step "huh" mod)))
 129
 130     (define (prefix-modifier->markup mod)
 131       (if (and (= 3 (pitch-step mod))
 132                (= FLAT (ly:pitch-alteration mod)))
 133           (if lowercase-root?
 134               empty-markup
 135               (ly:context-property context 'minorChordModifier))
 136           (make-simple-markup "huh")))
 137
 138     (define (filter-alterations alters)
 139       "Filter out uninteresting (natural) pitches from ALTERS."
 140
 141       (define (altered? p)
 142         (not (is-natural-alteration? p)))
 143
 144       (if
 145        (null? alters)
 146        '()
 147        (let* ((lst (filter altered? alters))
 148               (lp (last-pair alters)))
 149
 150          ;; we want the highest also if unaltered
 151          (if (and (not (altered? (car lp)))
 152                   (> (pitch-step (car lp)) 5))
 153              (append lst (last-pair alters))
 154              lst))))
 155
 156     (define (name-step pitch)
 157       (define (step-alteration pitch)
 158         (- (ly:pitch-alteration pitch)
 159            (natural-chord-alteration pitch)))
 160
 161       (let* ((num-markup (make-simple-markup
 162                           (number->string (pitch-step pitch))))
 163              (args (list num-markup))
 164              (major-seven-symbol (ly:context-property context 'majorSevenSymbol))
 165              (total
 166                     (if (and (= (ly:pitch-alteration pitch) 0)
 167                              (= (pitch-step pitch) 7)
 168                              (markup? major-seven-symbol))
 169                         (list major-seven-symbol)
 170                         (cons (accidental->markup (step-alteration pitch)) args))))
 171
 172         (make-line-markup total)))
 173
 174     (let* ((sep (ly:context-property context 'chordNameSeparator))
 175            (slashsep (ly:context-property context 'slashChordSeparator))
 176            (root-markup (name-root root lowercase-root?))
 177            (add-pitch-prefix (ly:context-property context 'additionalPitchPrefix))
 178            (add-markups (map (lambda (x) (glue-word-to-step add-pitch-prefix x))
 179                              addition-pitches))
 180            (filtered-alterations (filter-alterations alteration-pitches))
 181            (alterations (map name-step filtered-alterations))
 182            (suffixes (map suffix-modifier->markup suffix-modifiers))
 183            (prefixes (map prefix-modifier->markup prefix-modifiers))
 184            (main-markups (filter-main-name main-name))
 185            (to-be-raised-stuff (markup-join
 186                                 (append
 187                                  main-markups
 188                                  alterations
 189                                  suffixes
 190                                  add-markups) sep))
 191            (base-stuff (if (ly:pitch? bass-pitch)
 192                            (list slashsep (name-note bass-pitch #f))
 193                            '())))
 194
 195       (set! base-stuff
 196             (append
 197              (list root-markup
 198                    (conditional-kern-before (markup-join prefixes sep)
 199                                             (and (not (null? prefixes))
 200                                                  (= (ly:pitch-alteration root) NATURAL))
 201                                             (ly:context-property context 'chordPrefixSpacer))
 202                    (make-super-markup to-be-raised-stuff))
 203              base-stuff))
 204       (make-line-markup base-stuff)))
 205
 206   (define (ignatzek-format-exception
 207            root
 208            exception-markup
 209            bass-pitch
 210            lowercase-root?)
 211
 212     (make-line-markup
 213      `(
 214        ,(name-root root lowercase-root?)
 215        ,exception-markup
 216        .
 217        ,(if (ly:pitch? bass-pitch)
 218             (list (ly:context-property context 'slashChordSeparator)
 219                   (name-note bass-pitch #f))
 220             '()))))
 221
 222   (let* ((root (car in-pitches))
 223          (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
 224          (lowercase-root?
 225           (and (ly:context-property context 'chordNameLowercaseMinor)
 226                (let ((third (get-step 3 pitches)))
 227                  (and third (= (ly:pitch-alteration third) FLAT)))))
 228          (exceptions (ly:context-property context 'chordNameExceptions))
 229          (exception (assoc-get pitches exceptions))
 230          (prefixes '())
 231          (suffixes '())
 232          (add-steps '())
 233          (main-name #f)
 234          (bass-note
 235           (if (ly:pitch? inversion)
 236               inversion
 237               bass))
 238          (alterations '()))
 239
 240     (if exception
 241         (ignatzek-format-exception root exception bass-note lowercase-root?)
 242
 243         (begin
 244           ;; no exception.
 245           ;; handle sus4 and sus2 suffix: if there is a 3 together with
 246           ;; sus2 or sus4, then we explicitly say add3.
 247           (for-each
 248            (lambda (j)
 249              (if (get-step j pitches)
 250                  (begin
 251                    (if (get-step 3 pitches)
 252                        (begin
 253                          (set! add-steps (cons (get-step 3 pitches) add-steps))
 254                          (set! pitches (remove-step 3 pitches))))
 255                    (set! suffixes (cons (get-step j pitches) suffixes)))))
 256            '(2 4))
 257
 258           ;; do minor-3rd modifier.
 259           (if (and (get-step 3 pitches)
 260                    (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
 261               (set! prefixes (cons (get-step 3 pitches) prefixes)))
 262
 263           ;; lazy bum. Should write loop.
 264           (cond
 265            ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
 266            ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
 267            ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
 268            ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
 269            ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
 270
 271           (let* ((3-diff? (lambda (x y)
 272                             (= (- (pitch-step y) (pitch-step x)) 2)))
 273                  (split (split-at-predicate
 274                          3-diff? (remove-uptil-step 5 pitches))))
 275             (set! alterations (append alterations (car split)))
 276             (set! add-steps (append add-steps (cdr split)))
 277             (set! alterations (delq main-name alterations))
 278             (set! add-steps (delq main-name add-steps))
 279
 280
 281             ;; chords with natural (5 7 9 11 13) or leading subsequence.
 282             ;; etc. are named by the top pitch, without any further
 283             ;; alterations.
 284             (if (and
 285                  (ly:pitch? main-name)
 286                  (= 7 (pitch-step main-name))
 287                  (is-natural-alteration? main-name)
 288                  (pair? (remove-uptil-step 7 alterations))
 289                  (every is-natural-alteration? alterations))
 290                 (begin
 291                   (set! main-name (last alterations))
 292                   (set! alterations '())))
 293
 294             (ignatzek-format-chord-name
 295              root prefixes main-name alterations add-steps suffixes bass-note
 296              lowercase-root?))))))