Chord Analyzer/scheme

Zur Navigation springen Zur Suche springen
#(define (music-elts x)
   (if (not (ly:music? x))
       '()
       (ly:music-property x 'elements)))

#(define (music-name x)
   (if (not (ly:music? x))
       #f
       (ly:music-property x 'name)))

#(define (list-all-chords-from-music music)
   ;; each element of the list is ly:music
   (reverse!
    (let loop ((music music) (pitches '()))
      (let ((p  (music-name music)))
        (if (eq? p 'EventChord)
            (cons  music pitches)
            (let ((elt (ly:music-property music 'element)))
              (fold loop
                (if (ly:music? elt)
                    (loop elt pitches)
                    pitches)
                (music-elts music))))))))

#(define (naturalize-pitch p)
   ;; reduces alteration greater than a half tone step
   ;; #(display (naturalize-pitch #{ fes #}))
   ;; #<Pitch e >
   (let ((o (ly:pitch-octave p))
         (a (* 4 (ly:pitch-alteration p)))
         ;; alteration, a, in quarter tone steps,
         ;; for historical reasons
         (n (ly:pitch-notename p)))
     (cond
      ((and (> a 1)
            (or (eq? n 6)
                (eq? n 2)))
       (set! a (- a 2))
       (set! n (+ n 1)))
      ((and (< a -1)
            (or (eq? n 0) (eq? n 3)))
       (set! a (+ a 2))
       (set! n (- n 1))))
     (cond
      ((> a 2) (set! a (- a 4)) (set! n (+ n 1)))
      ((< a -2) (set! a (+ a 4)) (set! n (- n 1))))
     (ly:make-pitch o n (/ a 4))))

#(define (all-pitches-from-music music)
   "Return a list of all pitches from @var{music}."
   ;; Opencoded for efficiency.
   (reverse!
    (let loop ((music music) (pitches '()))
      (let ((p  (ly:music-property music 'pitch)))
        (if (ly:pitch? p)
            (cons (naturalize-pitch p) pitches)
            (let ((elt (ly:music-property music 'element)))
              (fold loop
                (if (ly:music? elt)
                    (loop elt pitches)
                    pitches)
                (ly:music-property music 'elements))))))))

#(define (pitch-equals? p1 p2)
   ;(write-me "pitch-equals? ----------------------------> " (list p1 p2))
   (and
    (= (ly:pitch-alteration p1) (ly:pitch-alteration p2))
    (= (ly:pitch-notename p1) (ly:pitch-notename p2))))

#(define (ist-in? the-chord the-scale)
   (let* ((chordpitches (all-pitches-from-music the-chord))
          (scalepitches (all-pitches-from-music the-scale)))
     ;(write-me "chordpitches ------------------> " chordpitches)
     ;(write-me "scalepitches ------------------> " scalepitches)
     (every (lambda (x)
              (let
               ((istdrin (->bool
                          (member x scalepitches pitch-equals?))))
               ;(write-me "ist-in? (x) ---------------------> " istdrin)
               istdrin))
       chordpitches)))

#(define (chords-contained chord-music the-scale)
   (let* ((chord-list (list-all-chords-from-music chord-music)))
     ; (write-me "chord-list ------------------> " chord-list)
     ;(write-me "ly:music-property event-chord-------> "
     ;(ly:music-property chord-music 'elements))
     ;(write-me "is list? chord-list -------------> " (list? chord-list))
     ;(write-me "length chord-list ---------------> " (length chord-list))
     ;(map (lambda (x) (write-me "ly:music elements of chord-list ---------------> " (ly:music? x))) chord-list)
     (filter (lambda (x) (ist-in? x the-scale)) chord-list)))))