scm/chord-entry.scm

   1 ;;;
   2 ;;; Generate chord names for the parser.
   3 ;;;
   4 ;;;
   5
   6 (define-public (construct-chord root duration modifications)
   7
   8   " Build a chord on root using modifiers in MODIFICATIONS. NoteEvent
   9 have duration DURATION..
  10
  11 Notes: natural 11 is left from chord if not explicitly specified.
  12
  13 Entry point for the parser.
  14
  15 "
  16   (let*
  17       ((flat-mods (flatten-list modifications))
  18        (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord))
  19        (complete-chord '())
  20        (bass #f)
  21        (inversion #f)
  22        (lead-mod #f)
  23        (explicit-11 #f)
  24        (start-additions #t))
  25
  26     (define (interpret-inversion chord mods)
  27       "Read /FOO   part. Side effect: INVERSION is set."
  28
  29       (if (and (>  (length mods) 1) (eq? (car mods) 'chord-slash))
  30           (begin
  31             (set! inversion (cadr mods))
  32             (set! mods (cddr mods))))
  33
  34       (interpret-bass chord mods))
  35
  36     (define (interpret-bass chord mods)
  37       "Read /+FOO   part. Side effect: BASS is set."
  38
  39       (if (and (>  (length mods) 1) (eq? (car mods) 'chord-bass))
  40           (begin
  41             (set! bass (cadr mods))
  42             (set! mods (cddr mods))))
  43
  44       (if (pair? mods)
  45           (scm-error  'chord-format "construct-chord" "Spurious garbage following chord: ~A" mods #f)
  46           )
  47
  48       chord
  49       )
  50
  51     (define (interpret-removals  chord mods)
  52       (define (inner-interpret chord mods)
  53         (if (and (pair? mods) (ly:pitch? (car mods)))
  54             (inner-interpret
  55              (remove-step (+ 1  (ly:pitch-steps (car mods))) chord)
  56              (cdr mods))
  57             (interpret-inversion chord mods))
  58             )
  59
  60       (if (and (pair? mods) (eq? (car mods) 'chord-caret))
  61           (inner-interpret chord (cdr mods))
  62           (interpret-inversion chord mods))
  63
  64       )
  65
  66     (define (interpret-additions  chord mods)
  67       "Interpret additions. TODO: should restrict modifier use?"
  68
  69       (cond
  70        ((null? mods) chord)
  71        ((ly:pitch? (car mods))
  72         (if (= (pitch-step (car mods)) 11)
  73             (set! explicit-11 #t))
  74         (interpret-additions
  75          (cons (car mods) (remove-step (pitch-step (car mods)) chord))
  76          (cdr mods)))
  77        ((procedure? (car mods))
  78         (interpret-additions
  79          ((car mods)  chord)
  80          (cdr mods)))
  81        (else (interpret-removals  chord mods))
  82       ))
  83
  84     (define (pitch-octavated-strictly-below p root)
  85       "return P, but octavated, so it is below  ROOT"
  86       (ly:make-pitch
  87        (+
  88         (ly:pitch-octave root)
  89         (if (> (ly:pitch-notename root)
  90                 (ly:pitch-notename p))
  91             0 -1))
  92        (ly:pitch-notename p)
  93        (ly:pitch-alteration p)))
  94
  95     (define (process-inversion complete-chord)
  96       "Take out inversion from COMPLETE-CHORD, and put it at the bottom.
  97 Return (INVERSION . REST-OF-CHORD).
  98
  99 Side effect: put original pitch in INVERSION.
 100 If INVERSION is not in COMPLETE-CHORD, it will be set as a BASS, overriding
 101 the bass specified.
 102
 103 "
 104       (let*
 105           (
 106            (root (car complete-chord))
 107            (inv? (lambda (y)
 108                    (and (= (ly:pitch-notename y)
 109                            (ly:pitch-notename inversion))
 110                         (= (ly:pitch-alteration y)
 111                            (ly:pitch-alteration inversion))
 112                         )))
 113
 114            (rest-of-chord (remove inv? complete-chord))
 115            (inversion-candidates (filter inv? complete-chord))
 116            (down-inversion (pitch-octavated-strictly-below inversion root))
 117            )
 118
 119         (if (pair? inversion-candidates)
 120             (set! inversion (car inversion-candidates))
 121             (begin
 122               (set! bass inversion)
 123               (set! inversion #f))
 124             )
 125         (if inversion
 126             (cons down-inversion rest-of-chord)
 127             rest-of-chord
 128             )
 129       ))
 130
 131     ;; root is always one octave too low.
 132
 133     ; something weird happens when this is removed,
 134     ; every other chord is octavated. --hwn... hmmm.
 135     (set! root (ly:pitch-transpose root (ly:make-pitch 1 0 0)))
 136
 137     ;; skip the leading : , we need some of the stuff following it.
 138     (if (pair? flat-mods)
 139         (if (eq? (car flat-mods)  'chord-colon)
 140             (set! flat-mods (cdr flat-mods))
 141             (set! start-additions #f)
 142         ))
 143
 144     ;; remember modifier
 145     (if (and (pair? flat-mods) (procedure? (car flat-mods)))
 146         (begin
 147           (set! lead-mod (car flat-mods))
 148           (set! flat-mods (cdr flat-mods))
 149           ))
 150
 151
 152
 153     ;; extract first  number if present, and build pitch list.
 154     (if (and (pair? flat-mods)
 155              (ly:pitch?  (car flat-mods))
 156              (not (eq? lead-mod sus-modifier))
 157              )
 158
 159         (begin
 160           (if (=  (pitch-step (car flat-mods)) 11)
 161               (set! explicit-11 #t))
 162           (set! base-chord
 163                 (stack-thirds (car flat-mods) the-canonical-chord))
 164           (set! flat-mods (cdr flat-mods))
 165         ))
 166
 167     ;; apply modifier
 168     (if (procedure? lead-mod)
 169         (set! base-chord (lead-mod base-chord)))
 170
 171     (set! complete-chord
 172           (if start-additions
 173            (interpret-additions base-chord flat-mods)
 174            (interpret-removals base-chord flat-mods)
 175            ))
 176
 177     (set! complete-chord (sort complete-chord ly:pitch<?))
 178
 179
 180     ;; If natural 11 + natural 3 is present, but not given explicitly,
 181     ;; we remove the 11.
 182     (if (and (not explicit-11)
 183              (get-step 11 complete-chord)
 184              (get-step 3 complete-chord)
 185              (= 0 (ly:pitch-alteration (get-step 11 complete-chord)))
 186              (= 0 (ly:pitch-alteration (get-step 3 complete-chord)))
 187              )
 188         (set! complete-chord (remove-step 11  complete-chord)) )
 189
 190
 191     ;; must do before processing inversion/bass, since they are
 192     ;; not relative to the root.
 193     (set! complete-chord (map (lambda (x) (ly:pitch-transpose x root))
 194                               complete-chord))
 195
 196
 197     (if inversion
 198         (set! complete-chord (process-inversion complete-chord)))
 199     (if bass
 200         (set! bass (pitch-octavated-strictly-below bass root)))
 201
 202
 203     (if #f
 204         (begin
 205           (write-me "\n*******\n" flat-mods)
 206           (write-me "root: " root)
 207           (write-me "base chord: " base-chord)
 208           (write-me "complete  chord: " complete-chord)
 209           (write-me "inversion: " inversion)
 210           (write-me "bass: " bass)))
 211
 212
 213
 214     (if inversion
 215         (make-chord (cdr complete-chord) bass duration (car complete-chord)
 216                     inversion)
 217         (make-chord complete-chord bass duration #f #f))
 218   ))
 219
 220
 221 (define (make-chord pitches bass duration inversion original-inv-pitch)
 222   "Make EventChord with notes corresponding to PITCHES, BASS and
 223 DURATION, and INVERSION."
 224   (define (make-note-ev pitch)
 225     (let*
 226         (
 227          (ev   (make-music-by-name 'NoteEvent))
 228          )
 229
 230       (ly:music-set-property! ev 'duration duration)
 231       (ly:music-set-property! ev 'pitch pitch)
 232       ev
 233       ))
 234
 235   (let*
 236       (
 237        (nots (map make-note-ev pitches))
 238        (bass-note (if bass (make-note-ev bass) #f))
 239        (inv-note (if inversion (make-note-ev inversion) #f))
 240        )
 241
 242
 243     (if bass-note
 244         (begin
 245           (ly:music-set-property! bass-note 'bass #t)
 246           (set! nots (cons bass-note nots))))
 247
 248
 249     (if inv-note
 250         (begin
 251           (ly:music-set-property! inv-note 'inversion #t)
 252           (ly:music-set-property! inv-note 'octavation
 253                                 (- (ly:pitch-octave inversion)
 254                                    (ly:pitch-octave original-inv-pitch))
 255                                 )
 256           (set! nots (cons inv-note nots))))
 257
 258     (make-event-chord nots)
 259   ))
 260
 261
 262 ;;;;;;;;;;;;;;;;
 263 ; chord modifiers change the pitch list.
 264
 265 (define (aug-modifier  pitches)
 266   (set! pitches  (replace-step (ly:make-pitch 0 4 SHARP) pitches))
 267   (replace-step (ly:make-pitch 0 2 0) pitches)
 268   )
 269
 270 (define (minor-modifier  pitches)
 271   (replace-step (ly:make-pitch 0 2 FLAT) pitches)
 272   )
 273
 274 (define (maj7-modifier  pitches)
 275   (set! pitches (remove-step 7 pitches))
 276   (cons  (ly:make-pitch 0 6 0) pitches)
 277   )
 278
 279 (define (dim-modifier  pitches)
 280   (set! pitches (replace-step (ly:make-pitch 0 2 FLAT) pitches))
 281   (set! pitches (replace-step (ly:make-pitch 0 4 FLAT) pitches))
 282   (set! pitches (replace-step (ly:make-pitch 0 6 DOUBLE-FLAT) pitches))
 283   pitches
 284   )
 285
 286 (define (sus-modifier  pitches)
 287    (remove-step (pitch-step (ly:make-pitch 0 2 0)) pitches)
 288   )
 289
 290 (define-public default-chord-modifier-list
 291   `((m . ,minor-modifier)
 292     (min . ,minor-modifier)
 293     (aug . , aug-modifier)
 294     (dim . , dim-modifier)
 295     (maj . , maj7-modifier)
 296     (sus . , sus-modifier)
 297     ))
 298
 299
 300 ;; canonical 13 chord.
 301 (define the-canonical-chord
 302   (map
 303    (lambda (n)
 304      (define (nca x)
 305        (if (= x 7) FLAT 0))
 306      (if (>= n 8)
 307          (ly:make-pitch 1 (- n 8) (nca n))
 308          (ly:make-pitch 0 (- n 1) (nca n))))
 309    '(1 3 5 7 9 11 13)))
 310
 311 (define (stack-thirds upper-step base)
 312   "Stack thirds listed in BASE until we reach UPPER-STEP. Add
 313 UPPER-STEP separately."
 314    (cond
 315     ((null? base) '())
 316     ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
 317      (cons (car base) (stack-thirds upper-step  (cdr base))))
 318     ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
 319      (list upper-step))
 320     (else '())
 321     ))
 322