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