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       (cond
  71        ((null? mods) chord)
  72        ((ly:pitch? (car mods))
  73         (if (= (ly:pitch-steps (car mods)) 11)
  74             (set! explicit-11 #t))
  75         (interpret-additions
  76          (cons (car mods) (remove-step (pitch-step (car mods)) chord))
  77          (cdr mods)))
  78        ((procedure? (car mods))
  79         (interpret-additions
  80          ((car mods)  chord)
  81          (cdr mods)))
  82        (else (interpret-removals  chord mods))
  83       ))
  84     (define (pitch-octavated-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 (filter-out-list inv? complete-chord))
 115            (inversion-candidates (filter-list inv? complete-chord))
 116            (down-inversion (pitch-octavated-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     (if #f
 138         (begin
 139           (write-me "\n*******\n" flat-mods)
 140           (write-me "root: " root)
 141           (write-me "base: " base-chord)
 142           (write-me "bass: " bass)))
 143
 144     ;; skip the leading : , we need some of the stuff following it.
 145     (if (pair? flat-mods)
 146         (if (eq? (car flat-mods)  'chord-colon)
 147             (set! flat-mods (cdr flat-mods))
 148             (set! start-additions #f)
 149         ))
 150
 151     ;; remember modifier
 152     (if (and (pair? flat-mods) (procedure? (car flat-mods)))
 153         (begin
 154           (set! lead-mod (car flat-mods))
 155           (set! flat-mods (cdr flat-mods))
 156           ))
 157
 158     ;; extract first  number if present, and build pitch list.
 159     (if (and (pair? flat-mods)
 160              (ly:pitch?  (car flat-mods))
 161              (not (eq? lead-mod sus-modifier))
 162              )
 163
 164         (begin
 165           (if (=  (pitch-step (car flat-mods)) 11)
 166               (set! explicit-11  #t))
 167           (set! base-chord
 168                 (map (lambda (y) (ly:pitch-transpose y root))
 169                      (stack-thirds (car flat-mods) the-canonical-chord)))
 170           (set! flat-mods (cdr flat-mods))
 171         ))
 172
 173     ;; apply modifier
 174     (if (procedure? lead-mod)
 175         (set! base-chord (lead-mod base-chord)))
 176
 177
 178     (set! complete-chord
 179           (if start-additions
 180            (interpret-additions base-chord flat-mods)
 181            (interpret-removals base-chord flat-mods)
 182            ))
 183
 184
 185     (set! complete-chord (map (lambda (x) (ly:pitch-transpose x root))
 186                               (sort complete-chord ly:pitch<?)))
 187
 188     ;; If natural 11 + natural 3 is present, but not given explicitly,
 189     ;; we remove the 11.
 190     (if (and (not explicit-11)
 191              (get-step 11 complete-chord)
 192              (get-step 3 complete-chord)
 193              (= 0 (ly:pitch-alteration (get-step 11 complete-chord)))
 194              (= 0 (ly:pitch-alteration (get-step 3 complete-chord)))
 195              )
 196
 197         (set! complete-chord (remove-step 11  complete-chord))
 198         )
 199
 200     (if inversion
 201         (set! complete-chord (process-inversion complete-chord)))
 202     (if bass
 203         (set! bass (pitch-octavated-below bass root)))
 204     (if inversion
 205         (make-chord (cdr complete-chord) bass duration (car complete-chord)
 206                     inversion)
 207         (make-chord complete-chord bass duration #f #f))
 208   ))
 209
 210
 211 (define (make-chord pitches bass duration inversion original-inv-pitch)
 212   "Make EventChord with notes corresponding to PITCHES, BASS and
 213 DURATION, and INVERSION."
 214   (define (make-note-ev pitch)
 215     (let*
 216         (
 217          (ev   (make-music-by-name 'NoteEvent))
 218          )
 219
 220       (ly:set-mus-property! ev 'duration duration)
 221       (ly:set-mus-property! ev 'pitch pitch)
 222       ev
 223       ))
 224
 225   (let*
 226       (
 227        (nots (map make-note-ev pitches))
 228        (bass-note (if bass (make-note-ev bass) #f))
 229        (inv-note (if inversion (make-note-ev inversion) #f))
 230        )
 231
 232
 233     (if bass-note
 234         (begin
 235           (ly:set-mus-property! bass-note 'bass #t)
 236           (set! nots (cons bass-note nots))))
 237
 238
 239     (if inv-note
 240         (begin
 241           (ly:set-mus-property! inv-note 'inversion #t)
 242           (ly:set-mus-property! inv-note 'original-pitch original-inv-pitch)
 243           (set! nots (cons inv-note nots))))
 244
 245     (make-event-chord nots)
 246   ))
 247
 248
 249 ;;;;;;;;;;;;;;;;
 250 ; chord modifiers change the pitch list.
 251
 252 (define (aug-modifier  pitches)
 253   (set! pitches  (replace-step (ly:make-pitch 0 4 1) pitches))
 254   (replace-step (ly:make-pitch 0 2 0) pitches)
 255   )
 256
 257 (define (minor-modifier  pitches)
 258   (replace-step (ly:make-pitch 0 2 -1) pitches)
 259   )
 260
 261 (define (maj7-modifier  pitches)
 262   (set! pitches (remove-step 7 pitches))
 263   (cons  (ly:make-pitch 0 6 0) pitches)
 264   )
 265
 266 (define (dim-modifier  pitches)
 267   (set! pitches (replace-step (ly:make-pitch 0 2 -1) pitches))
 268   (set! pitches (replace-step (ly:make-pitch 0 4 -1) pitches))
 269   (set! pitches (replace-step (ly:make-pitch 0 6 -2) pitches))
 270   pitches
 271   )
 272
 273 (define (sus-modifier  pitches)
 274    (remove-step (pitch-step (ly:make-pitch 0 2 0)) pitches)
 275   )
 276
 277 (define-public default-chord-modifier-list
 278   `((m . ,minor-modifier)
 279     (min . ,minor-modifier)
 280     (aug . , aug-modifier)
 281     (dim . , dim-modifier)
 282     (maj . , maj7-modifier)
 283     (sus . , sus-modifier)
 284     ))
 285
 286
 287 ;; canonical 13 chord.
 288 (define the-canonical-chord
 289   (map
 290    (lambda (n)
 291      (define (nca x)
 292        (if (= x 7) -1 0))
 293      (if (>= n 8)
 294          (ly:make-pitch 1 (- n 8) (nca n))
 295          (ly:make-pitch 0 (- n 1) (nca n))))
 296    '(1 3 5 7 9 11 13)))
 297
 298 (define (stack-thirds upper-step base)
 299   "Stack thirds listed in BASE until we reach UPPER-STEP. Add
 300 UPPER-STEP separately."
 301    (cond
 302     ((null? base) '())
 303     ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
 304      (cons (car base) (stack-thirds upper-step  (cdr base))))
 305     ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base)))
 306      (list upper-step))
 307     (else '())
 308     ))
 309