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