scm/chord-ignatzek-names.scm

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