%% This program, auto-ottava.ly. creates automatic ottavation of GNU Lilypond input.
%% Copyright (C) 2014-2015 David Nalesnik
%% This program is free software: you can redistribute it and/or modify
%% it under the terms of the GNU General Public License as published by
%% the Free Software Foundation, either version 3 of the License, or
%% (at your option) any later version.
%% This program is distributed in the hope that it will be useful,
%% but WITHOUT ANY WARRANTY; without even the implied warranty of
%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
%% GNU General Public License for more details.
%% You should have received a copy of the GNU General Public License
%% along with this program. If not, see .
\version "2.19.82"
#(define (ledger-line-no middle-C-pos p)
"Returns the number of ledger-lines a pitch @var{p} will have with
middle C position @var{middle-C-pos} expressed as staff-steps from the
middle staff line."
(let* ((ps (ly:pitch-steps p))
(mid-staff-steps (- middle-C-pos))
(top-line (+ mid-staff-steps 4))
(bottom-line (- mid-staff-steps 4))
(above? (> ps top-line))
(below? (< ps bottom-line))
(steps-outside-staff
(cond
(below? (- ps bottom-line))
(above? (- ps top-line))
(else 0))))
(truncate (/ steps-outside-staff 2))))
#(define (find-clefMiddleCPosition mus)
(let ((clef-pos -6)) ; treble is default
(for-some-music
(lambda (x)
(let ((n (ly:music-property x 'symbol)))
(and (eq? n 'middleCClefPosition)
(set! clef-pos (ly:music-property x 'value)))))
mus)
clef-pos))
#(define clefs
; An alist of (clef . position of middle C) pairs. Center line of staff = 0.
; For use when \ottavate is called on a music expression which begins with a
; clef other than treble, which has been set before that expression.
'((treble . -6)
(treble_8 . 1)
(bass . 6)
(bass_8 . 13)
(alto . 0)
(tenor . 2)))
#(define (make-ottava-music arg)
(list (make-music
'OttavaMusic
'ottava-number arg)))
#(define (select-ottava-music str)
(let ((options
'(("up-an-octave" . 1)
("down-an-octave" . -1)
("up-two-octaves" . 2)
("down-two-octaves" . -2)
("loco" . 0))))
(make-ottava-music (assoc-get str options))))
#(define naming-options
'((short . (("up-an-octave" . "8")
("down-an-octave" . "8")
("up-two-octaves" . "15")
("down-two-octaves" . "15")
("loco" . #f)))
(long . (("up-an-octave" . "8va")
("down-an-octave" . "8va bassa")
("up-two-octaves" . "15ma")
("down-two-octaves" . "15ma")
("loco" , #f)))
(default . #f)))
#(define (make-alternate-name name)
(let* ((ps (make-music
'PropertySet
'symbol 'ottavation
'value name))
(csm (make-music
'ContextSpeccedMusic
'element ps
'context-type 'Staff)))
(list csm)))
#(define (select-name displacement name-style)
(let* ((style (assoc-get name-style naming-options))
(name (if style
(assoc-get displacement style)
#f)))
(if name
(make-alternate-name name)
'())))
ottavate =
#(define-music-function (parser location upper lower options mus)
(number-pair? number-pair? list? ly:music?)
"Create ottavas for music based on numbers of ledger lines. Both @var{upper}
and @var{lower} are pairs specifying a range of ledger lines: @var{upper}
determines @code{8va} and @code{15ma}, and @var{lower} determines @var{8vb} and
@var{15mb}. Within this range (inclusive), an @code{8va} or @code{8ba} will
be created. Notes with numbers of ledger lines exceeding these ranges will be
assigned @code{15ma} or @code{15mb}.
Numbers of ledger lines above the staff are specified in @var{upper} as
positive integers, while ledger lines below the staff are specified in @var{lower}
as negative numbers.
The parameter @var{options} is an alist of symbol/value pairs. The symbol
@var{name-style} may be paired with @var{short}, @var{long}, or @var{default}.
The symbol @var{opening-clef} is for use when the music expression on which
@code{ottavate} is called begins with a clef other than treble which has been
set before that music expression.
The parameter @var{options} is not optional. Any symbol left out will be assigned
its default value. The empty list selects all default values.
"
(let* ((upper8 (car upper))
(upper15 (cdr upper))
(lower8 (car lower))
(lower15 (cdr lower))
(name-style (assoc-get 'name-style options 'default))
;; Since clef information is found by scanning the music expression, any clef
;; change must be within the music expression fed to ottavate. There is no access
;; to context properties from within a music function. User needs to tell
;; \ottavate the opening clef if it is other than treble and not set within
;; the music expression on which \ottavate is called.
(opening-clef (assoc-get 'opening-clef options 'treble))
(opening-middle-C-pos (assoc-get opening-clef clefs))
(loco (make-ottava-music 0)))
(define (select-displacement-string ledger-count)
(cond
((> ledger-count upper15)
"up-two-octaves")
((>= ledger-count upper8)
"up-an-octave")
((< ledger-count lower15)
"down-two-octaves")
((<= ledger-count lower8)
"down-an-octave")
(else "loco")))
(define (calc-displacement clef-pos mus-expr)
; Return a string designating displacement. "Loco" means "as written."
; Chords have the ledger-line count of their members averaged.
; Algorithm ought to be more sophisticated, and take context into consideration.
; We should not lose an ottava if one note in a passage dips below the
; threshold.
(cond
((music-is-of-type? mus-expr 'event-chord)
(let* ((elts (ly:music-property mus-expr 'elements))
(ledger-list
(map (lambda (e)
(ledger-line-no clef-pos (ly:music-property e 'pitch)))
elts))
(lowest (apply min ledger-list))
(highest (apply max ledger-list)))
(cond
((every positive? ledger-list)
(select-displacement-string lowest))
((every negative? ledger-list)
(select-displacement-string highest))
(else "loco"))))
((music-is-of-type? mus-expr 'note-event)
(let* ((pitch (ly:music-property mus-expr 'pitch))
(ledger-count (ledger-line-no clef-pos pitch)))
(select-displacement-string ledger-count)))))
(define (build-new-elts mus-expr new-expr prev clef-pos)
(if (null? mus-expr)
new-expr
(begin
(if (music-is-of-type? (car mus-expr) 'context-specification)
(set! clef-pos (find-clefMiddleCPosition (car mus-expr))))
(cond
;; We do not extend across rests for now.
((music-is-of-type? (car mus-expr) 'rest-event)
(build-new-elts
(cdr mus-expr)
(append
new-expr
loco
(list (car mus-expr)))
"loco" clef-pos))
((or (music-is-of-type? (car mus-expr) 'event-chord)
(music-is-of-type? (car mus-expr) 'note-event))
(let ((d (calc-displacement clef-pos (car mus-expr))))
(cond
((and d (not (string=? d prev)))
(build-new-elts
(cdr mus-expr)
(append
new-expr
(select-ottava-music d)
(select-name d name-style)
(list (car mus-expr)))
d clef-pos))
(else
(build-new-elts
(cdr mus-expr)
(append new-expr (list (car mus-expr)))
prev clef-pos)))))
; ew.
(else
(build-new-elts
(cdr mus-expr)
(append new-expr (list (car mus-expr)))
prev clef-pos))))))
(define (recurse music)
(let ((elts (ly:music-property music 'elements))
(e (ly:music-property music 'element)))
(if (ly:music? e)
(recurse e))
(if (pair? elts)
(if (or
(any (lambda (elt) (music-is-of-type? elt 'note-event)) elts)
(any (lambda (elt) (music-is-of-type? elt 'event-chord)) elts)
(any (lambda (elt) (music-is-of-type? elt 'rest-event)) elts))
(set! (ly:music-property music 'elements)
(build-new-elts elts '() "loco" opening-middle-C-pos))
(map recurse elts)))))
(recurse mus)
;(display-scheme-music mus) ; for testing
mus))
% %%%%%%%%%%% EXAMPLE %%%%%%%%%%%%
% {
% f''' g''' \clef bass g,, e,,
% }
% {
% \ottavate #'(4 . 7) #'(-4 . -7) #'((name-style . short)) { f''' g''' \clef bass g,, e,,}
% }
% music = { c d e f }
% % WRONG!
% {
% \clef bass \ottavate #'(4 . 7) #'(-4 . -7) #'() \music
% }
% % RIGHT!
% {
% \clef bass % not visible to \ottavate...
% \ottavate #'(4 . 7) #'(-4 . -7) #'((opening-clef . bass)) \music
% }
% musFour = \relative c' {
%
%
%
%
%
%
%
%
% }
% {
% \musFour
% }
% {
% \ottavate #'(3 . 6) #'(-3 . -6) #'((name-style . short)) \musFour
% }