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