scm/chord-ignatzek-names.scm

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