Modified enharmonic.ly (from snippets) (Peter Gentry)

[Peter Gentry]

I have revised this small file.

It will sort out accidentals removing double flats/sharps, setting all 
according to the current key signature or choosing sharp/flat
as first found in the case of a natural key.

\version "2.18.2"

% OS Vista and Frescobaldi

#(define s 0)
#(define k 0)
#(define nbuf 0)
#(define abuf 0)

 #(define (naturalize-pitch p tonic)
 (define sharpkey-list '((0 . 0) (1 . 1) (2 . 1) (3 . 0) (4 . 1) (5 . 1) (6 . 
1)))
 (define flatkey-list    '((0 . 0) (1 . 0) (2 . 0) (3 . 1) (4 . 0) (5 . 0) (6 . 
0)))
 (define sharp-list     '((0 . 0) (1 . 0) (2 . 1) (3 . 0) (4 . 0) (5 . 0) (6 . 
1)))
 (define flat-list        '((0 . 1) (1 . 0) (2 . 0) (3 . 1) (4 . 0) (5 . 0) (6 
. 0)))
 (let ((o (ly:pitch-octave p))
 (a (* 4 (ly:pitch-alteration p)))
;; alteration, a, in quarter tone steps,
;; for historical reasons
;; get currrent pitch 
(n (ly:pitch-notename p)))

;  if keychange event  determine if key contains flats s=1, naturals s=2 , or 
sharps s=3 ")   
(cond ((eq? tonic  1 )
  (set! s 2)
  (set! k 0)
  (if (and (eq? a 0) (eq? (cdr(assoc n sharpkey-list)) 1)) (set! s 3))
  (if (and (eq? a 0) (eq? (cdr(assoc n flatkey-list)) 1))   (set! s 1))
  (if (> a 0)  (set! s 3) )
  (if (< a 0)  (set! s 1) )
  ;;set preferred accidental
  (cond  ((and (eq? s 1) (eq? k 0) )  (set! k -2) ) )  ;;  flat key
  (cond  ((and (eq? s 3) (eq? k 0) )  (set! k 2) ) )   ;; sharp key
  (set! tonic 0)   ))

(set! nbuf n)
(set! abuf a)

; if no keychange event  naturalize the pitch 

; deal with double sharps 
(cond ((and (eq? tonic 0) (> a 2))   (begin  (set! n (+ n 1))  (set! a (- a 4)) 
          )))  
(cond ((> n 6)  (begin  (set! n (- n 7))  (set! o(+ o 1))                       
          )) )
(cond ((and (eq? (cdr(assoc nbuf sharp-list )) 1) (eq? abuf  4))  (begin (set! 
a (+ a 2)) ))  )

;deal with double flats
(cond ((and (eq? tonic 0) (< a -2)) (begin (set! n (- n 1))  (set! a(+ a 4)) )) 
)
(cond ((< n 0)  (begin (set! n(+ n 7)) (set! o(- o 1)) ))  )
(cond ((and (eq? (cdr(assoc nbuf flat-list )) 1) (eq? abuf -4)) (begin (set! a 
(- a 2)) )) ) 

;;deal with Cb to B and Fb to E
(cond ((and (eq? tonic 0 )  (< a -1)  (eq? (cdr(assoc n flat-list  )) 1)   
(begin (set! a  0)  (set! n (- n 1))))))

;;deal with; B# to C and E# toF
(cond  ((and (eq? tonic 0 )  (> a 1)    (eq? (cdr(assoc n sharp-list )) 1) 
(begin (set! a  0)  (set! n (+ n 1))))) )

;take account of preferred flats
(cond  ( (and   ( < k 0 )  ( > a  0) (eq? (cdr(assoc n sharp-list )) 0 ) )      
(begin  (set! a (* a -1)) (set! n (+ n 1)))))
(cond  ( (and   ( < k 0 )  ( > a  0) (eq? (cdr(assoc n sharp-list )) 1 ) )      
(begin  (set! a 0) (set! n (+ n 1)))))

;take account of preferred sharps
(cond  ((and   ( > k 0 )  ( < a  0)  (eq? (cdr(assoc n flat-list )) 0 )  )      
(begin  (set! a (* a -1)) (set! n (-  n 1)))))
(cond  ((and   ( > k 0 )  ( < a  0)  (eq? (cdr(assoc n flat-list )) 1 )  )      
(begin  (set! a 0) (set! n (-  n 1)))))

;; if natural key save first acceidental as preferred
(cond  ((and (eq? s 2) (eq? k 0) )  (set! k a) ) )   

;; modify the octave if necessary
(if ( < n 0) (begin (set! o (- o 1)) (set! n (+ n 7))))
(if  (> n 6) (begin (set! o (+ o 1)) (set! n (- n 7))))

(ly:make-pitch o n (/ a 4))

;; end scope of let
 ) 
;; end scope of naturalize-pitch
 ) 

#(define (naturalize music)
(let ((es (ly:music-property music 'elements))
       (e   (ly:music-property music 'element))
       (p   (ly:music-property music 'pitch))
       (t   (ly:music-property music 'tonic)))
(if (pair? es)
(ly:music-set-property!
music 'elements
(map (lambda (x) (naturalize x)) es)))

(if (ly:music? e)
(ly:music-set-property!
music 'element
(naturalize e)))

(if (ly:pitch? p)
(begin
(set! p (naturalize-pitch p 0))
(ly:music-set-property! music 'pitch p)))

(if (ly:pitch? t)
(begin
(set! t (naturalize-pitch t 1))
(ly:music-set-property! music 'tonic t)))

music)
) 


naturalizeMusic =
#(define-music-function (parser location m)
(ly:music?)
(naturalize m))


regards
Peter Gentry