scm/chord-ignatzek-names.scm

   1 ;;;
   2 ;;; chord-name.scm --  chord name utility functions
   3 ;;;
   4 ;;; source file of the GNU LilyPond music typesetter
   5 ;;;
   6 ;;; (c)  2000--2003  Han-Wen Nienhuys <hanwen@cs.uu.nl>
   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
  40 (define (replace-step p ps)
  41   "Copy PS, but replace the step of P in PS."
  42   (if (null? ps)
  43       '()
  44       (let*
  45           (
  46            (t (replace-step p (cdr ps)))
  47            )
  48
  49         (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
  50             (cons p t)
  51             (cons (car ps) t)
  52             ))
  53       ))
  54
  55 (define (remove-step x ps)
  56   "Copy PS, but leave out the Xth step."
  57   (if (null? ps)
  58       '()
  59       (let*
  60           (
  61            (t (remove-step x (cdr ps)))
  62            )
  63
  64         (if (= (- x 1) (ly:pitch-steps (car ps)))
  65             t
  66             (cons (car ps) t)
  67             ))
  68       ))
  69
  70
  71 (define-public (ignatzek-chord-names
  72                 in-pitches bass inversion
  73                 context)
  74
  75   (define (remove-uptil-step x ps)
  76     "Copy PS, but leave out everything below the Xth step."
  77     (if (null? ps)
  78         '()
  79         (if (< (ly:pitch-steps (car ps)) (- x 1))
  80             (remove-uptil-step x (cdr ps))
  81             ps)
  82         ))
  83
  84   (define name-root (ly:get-context-property context 'chordRootNamer))
  85   (define name-note
  86     (let ((nn (ly:get-context-property context 'chordNoteNamer)))
  87       (if (eq? nn '())
  88           ; replacing the next line with name-root gives guile-error...? -rz
  89
  90           ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
  91           (ly:get-context-property context 'chordRootNamer)
  92           ;; name-root
  93           nn)))
  94
  95   (define (is-natural-alteration? p)
  96     (= (natural-chord-alteration p)  (ly:pitch-alteration p)))
  97
  98
  99   (define (ignatzek-format-chord-name
 100            root
 101            prefix-modifiers
 102            main-name
 103            alteration-pitches
 104            addition-pitches
 105            suffix-modifiers
 106            bass-pitch
 107            )
 108
 109     "Format for the given (lists of) pitches. This is actually more
 110 work than classifying the pitches."
 111
 112     (define (filter-main-name p)
 113     "The main name: don't print anything for natural 5 or 3."
 114     (if
 115      (or (not (ly:pitch? p))
 116          (and (is-natural-alteration? p)
 117           (or (= (pitch-step p) 5)
 118               (= (pitch-step p) 3))))
 119      '()
 120      (list (name-step p))
 121      ))
 122
 123     (define (glue-word-to-step word x)
 124       (make-line-markup
 125        (list
 126         (make-simple-markup word)
 127         (name-step x)))
 128       )
 129
 130     (define (suffix-modifier->markup mod)
 131       (if (or (= 4 (pitch-step mod))
 132               (= 2 (pitch-step mod)))
 133           (glue-word-to-step "sus" mod)
 134           (glue-word-to-step "huh" mod)
 135           ))
 136
 137     (define (prefix-modifier->markup mod)
 138       (if (and (= 3 (pitch-step mod))
 139                (= -1 (ly:pitch-alteration mod)))
 140           (make-simple-markup "m")
 141           (make-simple-markup "huh")
 142           ))
 143
 144     (define (filter-alterations alters)
 145       "Filter out uninteresting (natural) pitches from ALTERS."
 146
 147       (define (altered? p)
 148         (not (is-natural-alteration? p)))
 149
 150       (if
 151        (null? alters)
 152        '()
 153        (let*
 154            (
 155             (l (filter-list altered? alters))
 156             (lp (last-pair alters))
 157             )
 158
 159          ;; we want the highest also if unaltered
 160          (if (and (not (altered? (car lp)))
 161                   (> (pitch-step (car lp)) 5))
 162              (append l (last-pair alters))
 163              l)
 164          )))
 165
 166     (define (name-step pitch)
 167       (define (step-alteration pitch)
 168         (- (ly:pitch-alteration pitch)
 169            (natural-chord-alteration pitch)
 170            ))
 171
 172       (let*
 173           (
 174            (num-markup (make-simple-markup
 175                         (number->string (pitch-step pitch))))
 176            (args (list num-markup))
 177            (total (if (= (ly:pitch-alteration pitch) 0)
 178                       (if (= (pitch-step pitch) 7)
 179                           (list (ly:get-context-property context 'majorSevenSymbol))
 180                           args)
 181                       (cons (accidental->markup (step-alteration pitch)) args)
 182                       ))
 183            )
 184
 185         (make-line-markup total)))
 186
 187     (let*
 188         (
 189          (sep (ly:get-context-property context 'chordNameSeparator))
 190          (root-markup (name-root root))
 191          (add-markups (map (lambda (x)
 192                              (glue-word-to-step "add" x))
 193                            addition-pitches))
 194          (filtered-alterations (filter-alterations alteration-pitches))
 195          (alterations (map name-step filtered-alterations))
 196          (suffixes (map suffix-modifier->markup suffix-modifiers))
 197          (prefixes (map prefix-modifier->markup prefix-modifiers))
 198          (main-markups (filter-main-name main-name))
 199          (to-be-raised-stuff (markup-join
 200                               (append
 201                                main-markups
 202                                alterations
 203                                suffixes
 204                                add-markups) sep))
 205          (base-stuff (if bass-pitch
 206                          (list sep (name-note bass-pitch))
 207                          '()))
 208          )
 209
 210       (set! base-stuff
 211             (append
 212              (list root-markup
 213                    (markup-join prefixes sep)
 214                    (make-super-markup to-be-raised-stuff))
 215              base-stuff))
 216       (make-line-markup       base-stuff)
 217
 218        ))
 219
 220   (let*
 221       (
 222        (root (car in-pitches))
 223        (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
 224        (exceptions (ly:get-context-property context 'chordNameExceptions))
 225        (exception (assoc-get-default pitches exceptions #f))
 226        (prefixes '())
 227        (suffixes '())
 228        (add-steps '())
 229        (main-name #f)
 230        (bass-note #f)
 231        (alterations '())
 232        )
 233
 234     (if
 235      exception
 236      (make-line-markup
 237       (list (name-root root) exception))
 238
 239      (begin                             ; no exception.
 240
 241        ; handle sus4 and sus2 suffix: if there is a 3 together with
 242        ; sus2 or sus4, then we explicitly say  add3.
 243        (map
 244         (lambda (j)
 245           (if (get-step j pitches)
 246               (begin
 247                 (if (get-step 3 pitches)
 248                     (begin
 249                       (set! add-steps (cons (get-step 3 pitches) add-steps))
 250                       (set! pitches (remove-step 3 pitches))
 251                       ))
 252                 (set! suffixes  (cons (get-step j pitches) suffixes))
 253                 )
 254               )
 255           ) '(2 4) )
 256
 257        ;; do minor-3rd modifier.
 258        (if (and (get-step 3 pitches)
 259                 (= (ly:pitch-alteration (get-step 3 pitches)) -1))
 260            (set! prefixes (cons (get-step 3 pitches) prefixes))
 261            )
 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
 272        (let*
 273            (
 274             (3-diff? (lambda (x y)
 275                        (= (- (pitch-step y) (pitch-step x)) 2)))
 276             (split (split-at 3-diff? (remove-uptil-step 5 pitches)))
 277             )
 278          (set! alterations (append alterations (car split)))
 279          (set! add-steps (append add-steps (cdr split)))
 280          (set! alterations (delq main-name alterations))
 281          (set! add-steps (delq main-name add-steps))
 282
 283          (if (ly:pitch? inversion)
 284              (set! bass-note inversion)
 285              )
 286
 287          (if (ly:pitch? bass)
 288              (set! bass-note bass)
 289              )
 290
 291          ;; chords with natural (5 7 9 11 13) or leading subsequence.
 292          ;; etc. are named by the top pitch, without any further
 293          ;; alterations.
 294          (if (and
 295               (ly:pitch? main-name)
 296               (= 7 (pitch-step main-name))
 297               (is-natural-alteration? main-name)
 298               (pair? (remove-uptil-step 7 alterations))
 299               (reduce (lambda (x y) (and x y))
 300                       (map is-natural-alteration? alterations)))
 301              (begin
 302                (set! main-name (tail alterations))
 303                (set! alterations '())
 304                ))
 305
 306          (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes bass-note)
 307          )
 308        ))))
 309