scm/chords-ignatzek.scm

   1 (define (natural-chord-alteration p)
   2   "Return the natural alteration for step P."
   3   (if (= (ly:pitch-steps p) 6)
   4       -1
   5       0))
   6
   7
   8 (define-public (alteration->text-accidental-markup alteration)
   9   (make-smaller-markup
  10    (make-raise-markup
  11     (if (= alteration -1)
  12         0.3
  13         0.6)
  14     (make-musicglyph-markup
  15      (string-append "accidentals-" (number->string alteration))))))
  16
  17 (define (accidental->markup alteration)
  18   "Return accidental markup for ALTERATION."
  19   (if (= alteration 0)
  20       (make-line-markup (list empty-markup))
  21       (conditional-kern-before
  22        (alteration->text-accidental-markup alteration)
  23        (= alteration -1) 0.2
  24        )))
  25
  26 (define (pitch->markup pitch)
  27   "Return pitch markup for PITCH."
  28   (make-line-markup
  29    (list
  30     (make-simple-markup
  31      (vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename pitch)))
  32     (make-normal-size-super-markup
  33      (accidental->markup (ly:pitch-alteration pitch))))))
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;;
  37
  38 (define-public (sequential-music-to-chord-exceptions seq)
  39   "Transform sequential music of <<a b c>>-\markup{ foobar } type to
  40  (cons ABC-PITCHES FOOBAR-MARKUP)
  41  "
  42
  43   (define (is-req-chord? m)
  44     (and
  45      (memq 'event-chord (ly:get-mus-property m 'types))
  46      (not (equal? (ly:make-moment 0 1) (ly:get-music-length m)))
  47     ))
  48
  49   (define (chord-to-exception-entry m)
  50     (let*
  51         (
  52          (elts   (ly:get-mus-property m 'elements))
  53          (pitches (map
  54                    (lambda (x)
  55                      (ly:get-mus-property x 'pitch)
  56                      )
  57                    (filter-list
  58                     (lambda (y) (memq 'note-event (ly:get-mus-property y 'types)))
  59                     elts)))
  60          (sorted  (sort pitches ly:pitch<? ))
  61          (root (car sorted))
  62          (non-root (map (lambda (x) (ly:pitch-diff x root)) (cdr sorted)))
  63          (texts (map
  64                  (lambda (x)
  65                    (ly:get-mus-property x 'text)
  66                    )
  67
  68                  (filter-list
  69                   (lambda (y)
  70                     (memq 'text-script-event
  71                           (ly:get-mus-property y 'types))) elts)
  72                  ))
  73          (text (if (null? texts)
  74                    #f
  75                    (car texts)))
  76
  77          )
  78       (cons non-root text)
  79     ))
  80
  81   (let*
  82     (
  83      (elts (filter-list is-req-chord? (ly:get-mus-property seq 'elements)))
  84      (alist (map chord-to-exception-entry elts))
  85      )
  86     (filter-list (lambda (x) (cdr x)) alist)
  87   ))
  88
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92 ;;
  93 ;; jazz-part 2
  94 ;;
  95 ;; after Klaus Ignatzek,   Die Jazzmethode fuer Klavier 1.
  96 ;;
  97 ;; The idea is: split chords into
  98 ;;
  99 ;;  ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
 100 ;;
 101 ;; and put that through a layout routine.
 102 ;;
 103 ;; the split is a procedural process, with lots of set!.
 104 ;;
 105
 106
 107 ;; todo: naming is confusing: steps  (0 based) vs. steps (1 based).
 108 (define (pitch-step p)
 109   "Musicological notation for an interval. Eg. C to D is 2."
 110   (+ 1 (ly:pitch-steps p)))
 111
 112 (define (get-step x ps)
 113   "Does PS have the X step? Return that step if it does."
 114   (if (null? ps)
 115       #f
 116       (if (= (- x 1) (ly:pitch-steps (car ps)))
 117           (car ps)
 118           (get-step x (cdr ps)))
 119       ))
 120
 121 (define (replace-step p ps)
 122   "Copy PS, but replace the step of P in PS."
 123   (if (null? ps)
 124       '()
 125       (let*
 126           (
 127            (t (replace-step p (cdr ps)))
 128            )
 129
 130         (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
 131             (cons p t)
 132             (cons (car ps) t)
 133             ))
 134       ))
 135
 136
 137 (define (remove-step x ps)
 138   "Copy PS, but leave out the Xth step."
 139   (if (null? ps)
 140       '()
 141       (let*
 142           (
 143            (t (remove-step x (cdr ps)))
 144            )
 145
 146         (if (= (- x 1) (ly:pitch-steps (car ps)))
 147             t
 148             (cons (car ps) t)
 149             ))
 150       ))
 151
 152
 153 (define-public (ignatzek-chord-names
 154                 in-pitches bass inversion
 155                 context)
 156
 157   (define (remove-uptil-step x ps)
 158     "Copy PS, but leave out everything below the Xth step."
 159     (if (null? ps)
 160         '()
 161         (if (< (ly:pitch-steps (car ps)) (- x 1))
 162             (remove-uptil-step x (cdr ps))
 163             ps)
 164         )
 165     )
 166
 167
 168   (define (is-natural-alteration? p)
 169     (= (natural-chord-alteration p)  (ly:pitch-alteration p))
 170     )
 171
 172
 173   (define (ignatzek-format-chord-name
 174            root
 175            prefix-modifiers
 176            main-name
 177            alteration-pitches
 178            addition-pitches
 179            suffix-modifiers
 180            bass-pitch
 181            )
 182
 183     "Format for the given (lists of) pitches. This is actually more
 184 work than classifying the pitches."
 185
 186     (define (filter-main-name p)
 187     "The main name: don't print anything for natural 5 or 3."
 188     (if
 189      (or (not (ly:pitch? p))
 190          (and (is-natural-alteration? p)
 191           (or (= (pitch-step p) 5)
 192               (= (pitch-step p) 3))))
 193      '()
 194      (list (name-step p))
 195      ))
 196
 197     (define (glue-word-to-step word x)
 198       (make-line-markup
 199        (list
 200         (make-simple-markup word)
 201         (name-step x)))
 202       )
 203
 204     (define (suffix-modifier->markup mod)
 205       (if (or (= 4 (pitch-step mod))
 206               (= 2 (pitch-step mod)))
 207           (glue-word-to-step "sus" mod)
 208           (glue-word-to-step "huh" mod)
 209           ))
 210
 211     (define (prefix-modifier->markup mod)
 212       (if (and (= 3 (pitch-step mod))
 213                (= -1 (ly:pitch-alteration mod)))
 214           (make-simple-markup "m")
 215           (make-simple-markup "huh")
 216           ))
 217
 218     (define (filter-alterations alters)
 219       "Filter out uninteresting (natural) pitches from ALTERS."
 220
 221       (define (altered? p)
 222         (not (is-natural-alteration? p)))
 223
 224       (if
 225        (null? alters)
 226        '()
 227        (let*
 228            (
 229             (l (filter-list altered? alters))
 230             (lp (last-pair alters))
 231             )
 232
 233          ;; we want the highest also if unaltered
 234          (if (and (not (altered? (car lp)))
 235                   (> (pitch-step (car lp)) 5))
 236              (append l (last-pair alters))
 237              l)
 238          )))
 239
 240     (define (name-step pitch)
 241       (define (step-alteration pitch)
 242         (- (ly:pitch-alteration pitch)
 243            (natural-chord-alteration pitch)
 244            ))
 245
 246       (let*
 247           (
 248            (num-markup (make-simple-markup
 249                         (number->string (pitch-step pitch))))
 250            (args (list num-markup))
 251            (total (if (= (ly:pitch-alteration pitch) 0)
 252                       (if (= (pitch-step pitch) 7)
 253                           (list (ly:get-context-property context 'majorSevenSymbol))
 254                           args)
 255                       (cons (accidental->markup (step-alteration pitch)) args)
 256                       ))
 257            )
 258
 259         (make-line-markup total)))
 260
 261     (let*
 262         (
 263          (sep (ly:get-context-property context 'chordNameSeparator))
 264          (root-markup (pitch->markup root))
 265          (add-markups (map (lambda (x)
 266                              (glue-word-to-step "add" x))
 267                            addition-pitches))
 268          (filtered-alterations (filter-alterations alteration-pitches))
 269          (alterations (map name-step filtered-alterations))
 270          (suffixes (map suffix-modifier->markup suffix-modifiers))
 271          (prefixes (map prefix-modifier->markup prefix-modifiers))
 272          (main-markups (filter-main-name main-name))
 273          (to-be-raised-stuff (markup-join
 274                               (append
 275                                main-markups
 276                                alterations
 277                                suffixes
 278                                add-markups) sep))
 279          (base-stuff (if bass-pitch
 280                          (list sep (pitch->markup bass-pitch))
 281                          '()))
 282          )
 283
 284       (set! base-stuff
 285             (append
 286              (list root-markup
 287                    (markup-join prefixes sep)
 288                    (make-super-markup to-be-raised-stuff))
 289              base-stuff))
 290       (make-line-markup       base-stuff)
 291
 292        ))
 293
 294   (let*
 295       (
 296        (root (car in-pitches))
 297        (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
 298        (exceptions (ly:get-context-property context 'chordNameExceptions))
 299        (exception (assoc-get-default pitches exceptions #f))
 300        (prefixes '())
 301        (suffixes '())
 302        (add-steps '())
 303        (main-name #f)
 304        (bass-note #f)
 305        (alterations '())
 306        )
 307
 308     (if
 309      exception
 310      (make-line-markup
 311       (list (pitch->markup root) exception))
 312
 313      (begin                             ; no exception.
 314
 315        ; handle sus4 and sus2 suffix: if there is a 3 together with
 316        ; sus2 or sus4, then we explicitly say  add3.
 317        (map
 318         (lambda (j)
 319           (if (get-step j pitches)
 320               (begin
 321                 (if (get-step 3 pitches)
 322                     (begin
 323                       (set! add-steps (cons (get-step 3 pitches) add-steps))
 324                       (set! pitches (remove-step 3 pitches))
 325                       ))
 326                 (set! suffixes  (cons (get-step j pitches) suffixes))
 327                 )
 328               )
 329           ) '(2 4) )
 330
 331        ;; do minor-3rd modifier.
 332        (if (and (get-step 3 pitches)
 333                 (= (ly:pitch-alteration (get-step 3 pitches)) -1))
 334            (set! prefixes (cons (get-step 3 pitches) prefixes))
 335            )
 336
 337        ;; lazy bum. Should write loop.
 338        (cond
 339         ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
 340         ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
 341         ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
 342         ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
 343         ((get-step 3 pitches) (set! main-name (get-step 3 pitches)))
 344         )
 345
 346        (let*
 347            (
 348             (3-diff? (lambda (x y)
 349                        (= (- (pitch-step y) (pitch-step x)) 2)))
 350             (split (split-at 3-diff? (remove-uptil-step 5 pitches)))
 351             )
 352          (set! alterations (append alterations (car split)))
 353          (set! add-steps (append add-steps (cdr split)))
 354          (set! alterations (delq main-name alterations))
 355          (set! add-steps (delq main-name add-steps))
 356
 357          (if (ly:pitch? inversion)
 358              (set! bass-note inversion)
 359              )
 360
 361          (if (ly:pitch? bass)
 362              (set! bass-note bass)
 363              )
 364
 365          ;; chords with natural (5 7 9 11 13) or leading subsequence.
 366          ;; etc. are named by the top pitch, without any further
 367          ;; alterations.
 368          (if (and
 369               (ly:pitch? main-name)
 370               (= 7 (pitch-step main-name))
 371               (is-natural-alteration? main-name)
 372               (pair? (remove-uptil-step 7 alterations))
 373               (reduce (lambda (x y) (and x y))
 374                       (map is-natural-alteration? alterations)))
 375              (begin
 376                (set! main-name (tail alterations))
 377                (set! alterations '())
 378                ))
 379
 380          (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes bass-note)
 381          )
 382        ))))
 383