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